# -*- perl -*- package Smokeping; use strict; use CGI; use Getopt::Long; use Pod::Usage; use Digest::MD5 qw(md5_base64); use SNMP_util; use SNMP_Session; use POSIX; use Smokeping::Config; use RRDs; use Sys::Syslog qw(:DEFAULT setlogsock); use Sys::Hostname; use Smokeping::Colorspace; use Smokeping::Master; use Smokeping::Slave; use Smokeping::RRDhelpers; use Smokeping::Graphs; use URI::Escape; setlogsock('unix') if grep /^ $^O $/xo, ("linux", "openbsd", "freebsd", "netbsd"); # make sure we do not end up with , in odd places where one would expect a '.' # we set the environment variable so that our 'kids' get the benefit too $ENV{LC_NUMERIC}='C'; if (POSIX::setlocale(&POSIX::LC_NUMERIC,"") ne "C") { die("Resetting LC_NUMERIC failed - try removing LC_ALL from the environment"); } use File::Basename; use Smokeping::Examples; use Smokeping::RRDtools; # globale persistent variables for speedy use vars qw($cfg $probes $VERSION $havegetaddrinfo $cgimode); $VERSION="2.004000"; # we want opts everywhere my %opt; BEGIN { $havegetaddrinfo = 0; eval 'use Socket6'; $havegetaddrinfo = 1 unless $@; } my $DEFAULTPRIORITY = 'info'; # default syslog priority my $logging = 0; # keeps track of whether we have a logging method enabled sub find_libdir { # find the directory where the probe and matcher modules are located # by looking for 'Smokeping/probes/FPing.pm' in @INC # # yes, this is ugly. Suggestions welcome. for (@INC) { -f "$_/Smokeping/probes/FPing.pm" or next; return $_; } return undef; } sub do_log(@); sub load_probe($$$$); sub dummyCGI::param { return wantarray ? () : ""; } sub dummyCGI::script_name { return wantarray ? () : ""; } sub load_probes ($){ my $cfg = shift; my %prbs; foreach my $probe (keys %{$cfg->{Probes}}) { my @subprobes = grep { ref $cfg->{Probes}{$probe}{$_} eq 'HASH' } keys %{$cfg->{Probes}{$probe}}; if (@subprobes) { my $modname = $probe; for my $subprobe (@subprobes) { $prbs{$subprobe} = load_probe($modname, $cfg->{Probes}{$probe}{$subprobe},$cfg, $subprobe); } } else { $prbs{$probe} = load_probe($probe, $cfg->{Probes}{$probe},$cfg, $probe); } } return \%prbs; }; sub load_probe ($$$$) { my $modname = shift; my $properties = shift; my $cfg = shift; my $name = shift; $name = $modname unless defined $name; # just in case, make sure we have the module loaded. unless # we are running as slave, this will already be the case # after reading the config file eval 'require Smokeping::probes::'.$modname; die "$@\n" if $@; my $rv; eval '$rv = Smokeping::probes::'.$modname.'->new( $properties,$cfg,$name);'; die "$@\n" if $@; die "Failed to load Probe $name (module $modname)\n" unless defined $rv; return $rv; } sub snmpget_ident ($) { my $host = shift; $SNMP_Session::suppress_warnings = 10; # be silent my @get = snmpget("${host}::1:1:1", qw(sysContact sysName sysLocation)); return undef unless @get; my $answer = join "/", grep { defined } @get; $answer =~ s/\s+//g; return $answer; } sub cgiurl { my ($q, $cfg) = @_; my %url_of = ( absolute => $cfg->{General}{cgiurl}, relative => q{}, original => $q->script_name, ); my $linkstyle = $cfg->{General}->{linkstyle}; die('unknown value for $cfg->{General}->{linkstyle}: ' . $linkstyle ) unless exists $url_of{$linkstyle}; return $url_of{$linkstyle}; } sub hierarchy ($){ my $q = shift; my $hierarchy = ''; if ($q->param('hierarchy')){ $hierarchy = 'hierarchy='.$q->param('hierarchy').';'; }; return $hierarchy; } sub lnk ($$) { my ($q, $path) = @_; if ($q->isa('dummyCGI')) { return $path . ".html"; } else { return cgiurl($q, $cfg) . "?".hierarchy($q)."target=" . $path; } } sub dyndir ($) { my $cfg = shift; return $cfg->{General}{dyndir} || $cfg->{General}{datadir}; } sub make_cgi_directories { my $targets = shift; my $dir = shift; my $perms = shift; while (my ($k, $v) = each %$targets) { next if ref $v ne "HASH"; if ( ! -d "$dir/$k" ) { my $saved = umask 0; mkdir "$dir/$k", oct($perms); umask $saved; } make_cgi_directories($targets->{$k}, "$dir/$k", $perms); } } sub update_dynaddr ($$){ my $cfg = shift; my $q = shift; my @target = split /\./, $q->param('target'); my $secret = md5_base64($q->param('secret')); my $address = $ENV{REMOTE_ADDR}; my $targetptr = $cfg->{Targets}; foreach my $step (@target){ return "Error: Unknown target $step" unless defined $targetptr->{$step}; $targetptr = $targetptr->{$step}; }; return "Error: Invalid target or secret" unless defined $targetptr->{host} and $targetptr->{host} eq "DYNAMIC/${secret}"; my $file = dyndir($cfg); for (0..$#target-1) { $file .= "/" . $target[$_]; ( -d $file ) || mkdir $file, 0755; } $file.= "/" . $target[-1]; my $prevaddress = "?"; my $snmp = snmpget_ident $address; if (-r "$file.adr" and not -z "$file.adr"){ open(D, "<$file.adr") or return "Error opening $file.adr: $!\n"; chomp($prevaddress = ); close D; } if ( $prevaddress ne $address){ open(D, ">$file.adr.new") or return "Error writing $file.adr.new: $!"; print D $address,"\n"; close D; rename "$file.adr.new","$file.adr"; } if ( $snmp ) { open (D, ">$file.snmp.new") or return "Error writing $file.snmp.new: $!"; print D $snmp,"\n"; close D; rename "$file.snmp.new", "$file.snmp"; } elsif ( -f "$file.snmp") { unlink "$file.snmp" }; } sub sendmail ($$$){ my $from = shift; my $to = shift; $to = $1 if $to =~ /<(.*?)>/; my $body = shift; if ($cfg->{General}{mailhost} and my $smtp = Net::SMTP->new([split /\s*,\s*/, $cfg->{General}{mailhost}],Timeout=>5) ){ $smtp->mail($from); $smtp->to(split(/\s*,\s*/, $to)); $smtp->data(); $smtp->datasend($body); $smtp->dataend(); $smtp->quit; } elsif ($cfg->{General}{sendmail} or -x "/usr/lib/sendmail"){ open (M, "|-") || exec (($cfg->{General}{sendmail} || "/usr/lib/sendmail"),"-f",$from,$to); print M $body; close M; } else { warn "ERROR: not sending mail to $to, as all methodes failed\n"; } } sub sendsnpp ($$){ my $to = shift; my $msg = shift; if ($cfg->{General}{snpphost} and my $snpp = Net::SNPP->new($cfg->{General}{snpphost}, Timeout => 60)){ $snpp->send( Pager => $to, Message => $msg) || do_debuglog("ERROR - ". $snpp->message); $snpp->quit; } else { warn "ERROR: not sending page to $to, as all SNPP setup failed\n"; } } sub min ($$) { my ($a, $b) = @_; return $a < $b ? $a : $b; } sub init_alerts ($){ my $cfg = shift; foreach my $al (keys %{$cfg->{Alerts}}) { my $x = $cfg->{Alerts}{$al}; next unless ref $x eq 'HASH'; if ($x->{type} eq 'matcher'){ $x->{pattern} =~ /(\S+)\((.+)\)/ or die "ERROR: Alert $al pattern entry '$_' is invalid\n"; my $matcher = $1; my $arg = $2; die "ERROR: matcher $matcher: all matchers start with a capital letter since version 2.0\n" unless $matcher =~ /^[A-Z]/; eval 'require Smokeping::matchers::'.$matcher; die "Matcher '$matcher' could not be loaded: $@\n" if $@; my $hand; eval "\$hand = Smokeping::matchers::$matcher->new($arg)"; die "ERROR: Matcher '$matcher' could not be instantiated\nwith arguments $arg:\n$@\n" if $@; $x->{minlength} = $hand->Length; $x->{maxlength} = $x->{minlength}; $x->{sub} = sub { $hand->Test(shift) } ; } else { my $sub_front = <{$x->{type}}; for(1){ SUB my $sub; my $sub_back = " return 1;\n }\n return 0;\n}\n"; my @ops = split /\s*,\s*/, $x->{pattern}; $x->{minlength} = scalar grep /^[!=><]/, @ops; $x->{maxlength} = $x->{minlength}; my $multis = scalar grep /^[*]/, @ops; my $it = ""; for(1..$multis){ my $ind = " " x ($_-1); my $extra = ""; for (1..$_-1) { $extra .= "-\$i$_"; } $sub .= <{maxlength}; my $incr = 0; for (@ops) { my $extra = ""; $it = " " x $multis; for(1..$multis){ $extra .= "-\$i$_"; }; /^(==|!=|<|>|<=|>=|\*)(\d+(?:\.\d*)?|U|S|\d*\*)(%?)$/ or die "ERROR: Alert $al pattern entry '$_' is invalid\n"; my $op = $1; my $value = $2; my $perc = $3; if ($op eq '*') { if ($value =~ /^([1-9]\d*)\*$/) { $value = $1; $x->{maxlength} += $value; $sub_front .= " my \$imax$multis = min(\@\$y - $x->{minlength}, $value);\n"; $sub_back .= "\n"; $sub .= <= min(\$maxlength$extra,\$imax$multis); FOR $multis--; next; } else { die "ERROR: multi-match operator * must be followed by Number* in Alert $al definition\n"; } } elsif ($value eq 'U') { if ($op eq '==') { $sub .= "$it next if defined \$y->[$i$extra];\n"; } elsif ($op eq '!=') { $sub .= "$it next unless defined \$y->[$i$extra];\n"; } else { die "ERROR: invalid operator $op in connection U in Alert $al definition\n"; } } elsif ($value eq 'S') { if ($op eq '==') { $sub .= "$it next unless defined \$y->[$i$extra] and \$y->[$i$extra] eq 'S';\n"; } else { die "ERROR: S is only valid with == operator in Alert $al definition\n"; } } elsif ($value eq '*') { if ($op ne '==') { die "ERROR: operator $op makes no sense with * in Alert $al definition\n"; } # do nothing else ... } else { if ( $x->{type} eq 'loss') { die "ERROR: loss should be specified in % (alert $al pattern)\n" unless $perc eq "%"; } elsif ( $x->{type} eq 'rtt' ) { $value /= 1000; } else { die "ERROR: unknown alert type $x->{type}\n"; } $sub .= <[$i$extra] $it and \$y->[$i$extra] =~ /^\\d/ $it and \$y->[$i$extra] $op $value; IF } $i++; } $sub_front .= "$it my \$minlength = $x->{minlength};\n"; $sub_front .= "$it my \$maxlength = $x->{maxlength};\n"; $sub_front .= "$it next if scalar \@\$y < \$minlength ;\n"; do_debuglog(<{pattern} $sub_front$sub$sub_back COMP $x->{sub} = eval ( $sub_front.$sub.$sub_back ); die "ERROR: compiling alert pattern $al ($x->{pattern}): $@\n" if $@; } } } sub check_filter ($$) { my $cfg = shift; my $name = shift; # remove the path prefix when filtering and make sure the path again starts with / my $prefix = $cfg->{General}{datadir}; $name =~ s|^${prefix}/*|/|; # if there is a filter do neither schedule these nor make rrds if ($opt{filter} && scalar @{$opt{filter}}){ my $ok = 0; for (@{$opt{filter}}){ /^\!(.+)$/ && do { my $rx = $1; $name !~ /^$rx/ && do{ $ok = 1}; next; }; /^(.+)$/ && do { my $rx = $1; $name =~ /^$rx/ && do {$ok = 1}; next; }; } return $ok; }; return 1; } sub add_targets ($$$$); sub add_targets ($$$$){ my $cfg = shift; my $probes = shift; my $tree = shift; my $name = shift; die "Error: Invalid Probe: $tree->{probe}" unless defined $probes->{$tree->{probe}}; my $probeobj = $probes->{$tree->{probe}}; foreach my $prop (keys %{$tree}) { if (ref $tree->{$prop} eq 'HASH'){ add_targets $cfg, $probes, $tree->{$prop}, "$name/$prop"; } if ($prop eq 'host' and ( check_filter($cfg,$name) and $tree->{$prop} !~ m|^/| )) { if($tree->{host} =~ /^DYNAMIC/) { $probeobj->add($tree,$name); } else { $probeobj->add($tree,$tree->{host}); } } } } sub init_target_tree ($$$$); # predeclare recursive subs sub init_target_tree ($$$$) { my $cfg = shift; my $probes = shift; my $tree = shift; my $name = shift; my $hierarchies = $cfg->{__hierarchies}; die "Error: Invalid Probe: $tree->{probe}" unless defined $probes->{$tree->{probe}}; my $probeobj = $probes->{$tree->{probe}}; if ($tree->{alerts}){ die "ERROR: no Alerts section\n" unless exists $cfg->{Alerts}; $tree->{alerts} = [ split(/\s*,\s*/, $tree->{alerts}) ] unless ref $tree->{alerts} eq 'ARRAY'; $tree->{fetchlength} = 0; foreach my $al (@{$tree->{alerts}}) { die "ERROR: alert $al ($name) is not defined\n" unless defined $cfg->{Alerts}{$al}; $tree->{fetchlength} = $cfg->{Alerts}{$al}{maxlength} if $tree->{fetchlength} < $cfg->{Alerts}{$al}{maxlength}; } }; # fill in menu and title if missing $tree->{menu} ||= $tree->{host} || "unknown"; $tree->{title} ||= $tree->{host} || "unknown"; my $real_path = $name; my $dataroot = $cfg->{General}{datadir}; $real_path =~ s/^$dataroot\/*//; my @real_path = split /\//, $real_path; foreach my $prop (keys %{$tree}) { if (ref $tree->{$prop} eq 'HASH'){ if (not -d $name and not $cgimode) { mkdir $name, 0755 or die "ERROR: mkdir $name: $!\n"; }; if (defined $tree->{$prop}{parents}){ for my $parent (split /\s/, $tree->{$prop}{parents}){ my($hierarchy,$path)=split /:/,$parent,2; die "ERROR: unknown hierarchy $hierarchy in $name. Make sure it is listed in Presentation->hierarchies.\n" unless $cfg->{Presentation}{hierarchies} and $cfg->{Presentation}{hierarchies}{$hierarchy}; my @path = split /\/+/, $path; shift @path; # drop empty root element; if ( not exists $hierarchies->{$hierarchy} ){ $hierarchies->{$hierarchy} = {}; }; my $point = $hierarchies->{$hierarchy}; for my $item (@path){ if (not exists $point->{$item}){ $point->{$item} = {}; } $point = $point->{$item}; }; $point->{$prop}{__tree_link} = $tree->{$prop}; $point->{$prop}{__real_path} = [ @real_path,$prop ]; } } init_target_tree $cfg, $probes, $tree->{$prop}, "$name/$prop"; } if ($prop eq 'host' and check_filter($cfg,$name) and $tree->{$prop} !~ m|^/|) { # print "init $name\n"; my $step = $probeobj->step(); # we have to do the add before calling the _pings method, it won't work otherwise my $pings = $probeobj->_pings($tree); my @slaves = (""); if ($tree->{slaves}){ push @slaves, split /\s+/, $tree->{slaves}; }; for my $slave (@slaves){ die "ERROR: slave '$slave' is not defined in the '*** Slaves ***' section!\n" unless $slave eq '' or defined $cfg->{Slaves}{$slave}; my $s = $slave ? "~".$slave : ""; my @create = ($name.$s.".rrd", "--start",(time-1),"--step",$step, "DS:uptime:GAUGE:".(2*$step).":0:U", "DS:loss:GAUGE:".(2*$step).":0:".$pings, "DS:median:GAUGE:".(2*$step).":0:180", (map { "DS:ping${_}:GAUGE:".(2*$step).":0:180" } 1..$pings), (map { "RRA:".(join ":", @{$_}) } @{$cfg->{Database}{_table}} )); if (not -f $name.$s.".rrd"){ unless ($cgimode) { do_debuglog("Calling RRDs::create(@create)"); RRDs::create(@create); my $ERROR = RRDs::error(); do_log "RRDs::create ERROR: $ERROR\n" if $ERROR; } } else { shift @create; # remove the filename my ($fatal, $comparison) = Smokeping::RRDtools::compare($name.$s.".rrd", \@create); die("Error: RRD parameter mismatch ('$comparison'). You must delete $name$s.rrd or fix the configuration parameters.\n") if $fatal; warn("Warning: RRD parameter mismatch('$comparison'). Continuing anyway.\n") if $comparison and not $fatal; Smokeping::RRDtools::tuneds($name.$s.".rrd", \@create); } } } } }; sub enable_dynamic($$$$); sub enable_dynamic($$$$){ my $cfg = shift; my $cfgfile = $cfg->{__cfgfile}; my $tree = shift; my $path = shift; my $email = ($tree->{email} || shift); my $print; die "ERROR: smokemail property in $cfgfile not specified\n" unless defined $cfg->{General}{smokemail}; die "ERROR: cgiurl property in $cfgfile not specified\n" unless defined $cfg->{General}{cgiurl}; if (defined $tree->{host} and $tree->{host} eq 'DYNAMIC' ) { if ( not defined $email ) { warn "WARNING: No email address defined for $path\n"; } else { my $usepath = $path; $usepath =~ s/\.$//; my $secret = int(rand 1000000); my $md5 = md5_base64($secret); open C, "<$cfgfile" or die "ERROR: Reading $cfgfile: $!\n"; open G, ">$cfgfile.new" or die "ERROR: Writing $cfgfile.new: $!\n"; my $section ; my @goal = split /\./, $usepath; my $indent = "+"; my $done; while (){ $done && do { print G; next }; /^\s*\Q*** Targets ***\E\s*$/ && do{$section = 'match'}; @goal && $section && /^\s*\Q${indent}\E\s*\Q$goal[0]\E/ && do { $indent .= "+"; shift @goal; }; (not @goal) && /^\s*host\s*=\s*DYNAMIC$/ && do { print G "host = DYNAMIC/$md5\n"; $done = 1; next; }; print G; } close G; rename "$cfgfile.new", $cfgfile; close C; my $body; open SMOKE, $cfg->{General}{smokemail} or die "ERROR: can't read $cfg->{General}{smokemail}: $!\n"; while (){ s/<##PATH##>/$usepath/ig; s/<##SECRET##>/$secret/ig; s/<##URL##>/$cfg->{General}{cgiurl}/; s/<##FROM##>/$cfg->{General}{contact}/; s/<##OWNER##>/$cfg->{General}{owner}/; s/<##TO##>/$email/; $body .= $_; } close SMOKE; my $mail; print STDERR "Sending smoke-agent for $usepath to $email ... "; sendmail $cfg->{General}{contact},$email,$body; print STDERR "DONE\n"; } } foreach my $prop ( keys %{$tree}) { enable_dynamic $cfg, $tree->{$prop},"$path$prop.",$email if ref $tree->{$prop} eq 'HASH'; } }; sub get_tree($$){ my $cfg = shift; my $open = shift; my $tree = $cfg->{Targets}; for (@{$open}){ $tree = $tree->{$_}; } return $tree; } sub target_menu($$$$;$); sub target_menu($$$$;$){ my $tree = shift; my $open = shift; $open = [@$open]; # make a copy my $path = shift; my $filter = shift; my $suffix = shift || ''; my $print; my $current = shift @{$open} || ""; my @hashes; foreach my $prop (sort {exists $tree->{$a}{_order} ? ($tree->{$a}{_order} <=> $tree->{$b}{_order}) : ($a cmp $b)} grep { ref $tree->{$_} eq 'HASH' and not /^__/ } keys %$tree) { push @hashes, $prop; } return wantarray ? () : "" unless @hashes; $print .= qq{\n} unless $filter; my @matches; for my $key (@hashes) { my $menu = $key; my $title = $key; my $hide; my $host; my $menuextra; if ($tree->{$key}{__tree_link} and $tree->{$key}{__tree_link}{menu}){ $menu = $tree->{$key}{__tree_link}{menu}; $title = $tree->{$key}{__tree_link}{title}; $host = $tree->{$key}{__tree_link}{host}; $menuextra = $tree->{$key}{__tree_link}{menuextra}; next if $tree->{$key}{__tree_link}{hide} and $tree->{$key}{__tree_link}{hide} eq 'yes'; } elsif ($tree->{$key}{menu}) { $menu = $tree->{$key}{menu}; $title = $tree->{$key}{title}; $host = $tree->{$key}{host}; $menuextra = $tree->{$key}{menuextra}; next if $tree->{$key}{hide} and $tree->{$key}{hide} eq 'yes'; } # no menuextra for multihost if (not $host or $host =~ m|^/|){ $menuextra = undef; } my $class = 'menuitem'; if ($key eq $current ){ if ( @$open ) { $class = 'menuopen'; } else { $class = 'menuactive'; } }; if ($filter){ if (($menu and $menu =~ /$filter/i) or ($title and $title =~ /$filter/i)){ push @matches, ["$path$key$suffix",$menu,$class]; }; push @matches, target_menu($tree->{$key}, $open, "$path$key.",$filter, $suffix); } else { $menu =~ s/ / /g; my $menuclass = "menulink"; if ($key eq $current and !@$open) { $menuclass = "menulinkactive"; } if ($menuextra){ $menuextra =~ s/{HOST}/#$host/g; $menuextra =~ s/{CLASS}/$menuclass/g; $menuextra = ' '.$menuextra; } else { $menuextra = ''; } my $menuadd =""; $menuadd = " " x (20 - length($menu.$menuextra)) if length($menu.$menuextra) < 20; $print .= qq{\n}; if ($key eq $current){ my $prline = target_menu $tree->{$key}, $open, "$path$key.",$filter, $suffix; $print .= qq{} if $prline; } } } $print .= "\n" unless $filter; if ($filter){ if (wantarray()){ return @matches; } else { for my $entry (sort {$a->[1] cmp $b->[1] } grep {ref $_ eq 'ARRAY'} @matches) { my ($href,$menu,$class) = @{$entry}; $print .= qq{\n}; } } } return $print; }; sub fill_template ($$;$){ my $template = shift; my $subst = shift; my $data = shift; if ($template){ my $line = $/; undef $/; open I, $template or return undef; $data = ; close I; $/ = $line; } foreach my $tag (keys %{$subst}) { my $replace = $subst->{$tag} || ''; $data =~ s/<##${tag}##>/$replace/g; } return $data; } sub exp2seconds ($) { my $x = shift; $x =~/(\d+)m/ && return $1*60; $x =~/(\d+)h/ && return $1*60*60; $x =~/(\d+)d/ && return $1*60*60*24; $x =~/(\d+)w/ && return $1*60*60*24*7; $x =~/(\d+)y/ && return $1*60*60*24*365; return $x; } sub calc_stddev { my $rrd = shift; my $id = shift; my $pings = shift; my @G = map {("DEF:pin${id}p${_}=${rrd}:ping${_}:AVERAGE","CDEF:p${id}p${_}=pin${id}p${_},UN,0,pin${id}p${_},IF")} 1..$pings; push @G, "CDEF:pings${id}="."$pings,p${id}p1,UN,".join(",",map {"p${id}p$_,UN,+"} 2..$pings).",-"; push @G, "CDEF:m${id}="."p${id}p1,".join(",",map {"p${id}p$_,+"} 2..$pings).",pings${id},/"; push @G, "CDEF:sdev${id}=p${id}p1,m${id},-,DUP,*,".join(",",map {"p${id}p$_,m${id},-,DUP,*,+"} 2..$pings).",pings${id},/,SQRT"; return @G; } sub brighten_webcolor { my $web = shift; my @rgb = Smokeping::Colorspace::web_to_rgb($web); my @hsl = Smokeping::Colorspace::rgb_to_hsl(@rgb); $hsl[2] = (1 - $hsl[2]) * (2/3) + $hsl[2]; @rgb = Smokeping::Colorspace::hsl_to_rgb(@hsl); return Smokeping::Colorspace::rgb_to_web(@rgb); } sub get_overview ($$$$){ my $cfg = shift; my $q = shift; my $tree = shift; my $open = shift; my $page =""; my $date = $cfg->{Presentation}{overview}{strftime} ? POSIX::strftime($cfg->{Presentation}{overview}{strftime}, localtime(time)) : scalar localtime(time); if ( $RRDs::VERSION >= 1.199908 ){ $date =~ s|:|\\:|g; } foreach my $prop (sort {exists $tree->{$a}{_order} ? ($tree->{$a}{_order} <=> $tree->{$b}{_order}) : ($a cmp $b)} grep { ref $tree->{$_} eq 'HASH' and not /^__/ } keys %$tree) { my @slaves; my $phys_tree = $tree->{$prop}; my $phys_open = $open; my $dir = ""; if ($tree->{$prop}{__tree_link}){ $phys_tree = $tree->{$prop}{__tree_link}; $phys_open = [ @{$tree->{$prop}{__real_path}} ]; pop @$phys_open; } next unless $phys_tree->{host}; next if $phys_tree->{hide} and $phys_tree->{hide} eq 'yes'; if (not $phys_tree->{nomasterpoll} or $phys_tree->{nomasterpoll} eq 'no'){ @slaves = (""); }; if ($phys_tree->{host} =~ m|^/|){ # multi host syntax @slaves = split /\s+/, $phys_tree->{host}; } elsif ($phys_tree->{slaves}){ push @slaves, split /\s+/,$phys_tree->{slaves}; } next if 0 == @slaves; for (@$phys_open) { $dir .= "/$_"; mkdir $cfg->{General}{imgcache}.$dir, 0755 unless -d $cfg->{General}{imgcache}.$dir; die "ERROR: creating $cfg->{General}{imgcache}$dir: $!\n" unless -d $cfg->{General}{imgcache}.$dir; } my @G; #Graph 'script' my $max = $cfg->{Presentation}{overview}{max_rtt} || "100000"; my $probe = $probes->{$phys_tree->{probe}}; my $pings = $probe->_pings($phys_tree); my $i = 0; my @colors = split /\s+/, $cfg->{Presentation}{multihost}{colors}; my $ProbeUnit = $probe->ProbeUnit(); for my $slave (@slaves){ $i++; my $rrd; my $medc; my $label; if ($slave =~ m|^/|){ # multihost entry $rrd = $cfg->{General}{datadir}.'/'.$slave.".rrd"; $medc = shift @colors; my @tree_path = split /\//,$slave; shift @tree_path; my ($host,$real_slave) = split /~/, $tree_path[-1]; #/ $tree_path[-1]= $host; my $tree = get_tree($cfg,\@tree_path); # not all multihost entries must have the same number of pings $probe = $probes->{$tree->{probe}}; $pings = $probe->_pings($tree); $label = $tree->{menu}; # if there are multiple units ... lets say so ... if ($ProbeUnit ne $probe->ProbeUnit()){ $ProbeUnit = 'var units'; } if ($real_slave){ $label .= "<". $cfg->{Slaves}{$real_slave}{display_name}; } $label = sprintf("%-20s",$label); push @colors, $medc; } else { my $s = $slave ? "~".$slave : ""; $rrd = $cfg->{General}{datadir}.$dir.'/'.$prop.$s.'.rrd'; $medc = $slave ? $cfg->{Slaves}{$slave}{color} : ($cfg->{Presentation}{overview}{median_color} || shift @colors); if ($#slaves > 0){ $label = sprintf("%-25s","median RTT from ".($slave ? $cfg->{Slaves}{$slave}{display_name} : $cfg->{General}{display_name} || hostname)); } else { $label = "med RTT" } }; my $sdc = $medc; $sdc =~ s/^(......).*/${1}30/; push @G, "DEF:median$i=${rrd}:median:AVERAGE", "DEF:loss$i=${rrd}:loss:AVERAGE", "CDEF:ploss$i=loss$i,$pings,/,100,*", "CDEF:dm$i=median$i,0,$max,LIMIT", calc_stddev($rrd,$i,$pings), "CDEF:dmlow$i=dm$i,sdev$i,2,/,-", "CDEF:s2d$i=sdev$i", # "CDEF:dm2=median,1.5,*,0,$max,LIMIT", # "LINE1:dm2", # this is for kicking things down a bit "AREA:dmlow$i", "AREA:s2d${i}#${sdc}::STACK", "LINE1:dm$i#${medc}:${label}", "VDEF:avmed$i=median$i,AVERAGE", "VDEF:avsd$i=sdev$i,AVERAGE", "CDEF:msr$i=median$i,POP,avmed$i,avsd$i,/", "VDEF:avmsr$i=msr$i,AVERAGE", "GPRINT:avmed$i:%5.1lf %ss av md ", "GPRINT:ploss$i:AVERAGE:%5.1lf %% av ls", "GPRINT:avsd$i:%5.1lf %ss av sd", "GPRINT:avmsr$i:%5.1lf %s am/as\\l"; } my ($graphret,$xs,$ys) = RRDs::graph ($cfg->{General}{imgcache}.$dir."/${prop}_mini.png", # '--lazy', '--start','-'.exp2seconds($cfg->{Presentation}{overview}{range}), '--title',$phys_tree->{title}, '--height',$cfg->{Presentation}{overview}{height}, '--width',$cfg->{Presentation}{overview}{width}, '--vertical-label', $ProbeUnit, '--imgformat','PNG', '--alt-autoscale-max', '--alt-y-grid', '--rigid', '--lower-limit','0', @G, "COMMENT:$date\\r"); my $ERROR = RRDs::error(); $page .= "
"; if (defined $ERROR) { $page .= "ERROR: $ERROR
".join("
", map {"'$_'"} @G); } else { $page.="". "{General}{imgurl}.$dir."/${prop}_mini.png\">"; } $page .="
" } return $page; } sub findmax ($$) { my $cfg = shift; my $rrd = shift; # my $pings = "ping".int($cfg->{Database}{pings}/1.1); my %maxmedian; my @maxmedian; for (@{$cfg->{Presentation}{detail}{_table}}) { my ($desc,$start) = @{$_}; $start = exp2seconds($start); my ($graphret,$xs,$ys) = RRDs::graph ("dummy", '--start', -$start, '--end','-'.int($start / $cfg->{Presentation}{detail}{width}), "DEF:maxping=${rrd}:median:AVERAGE", 'PRINT:maxping:MAX:%le' ); my $ERROR = RRDs::error(); do_log $ERROR if $ERROR; my $val = $graphret->[0]; $val = 0 if $val =~ /nan/i; $maxmedian{$start} = $val; push @maxmedian, $val; } my $med = (sort @maxmedian)[int(($#maxmedian) / 2 )]; my $max = 0.000001; foreach my $x ( keys %maxmedian ){ if ( not defined $cfg->{Presentation}{detail}{unison_tolerance} or ( $maxmedian{$x} <= $cfg->{Presentation}{detail}{unison_tolerance} * $med and $maxmedian{$x} >= $med / $cfg->{Presentation}{detail}{unison_tolerance}) ){ $max = $maxmedian{$x} unless $maxmedian{$x} < $max; $maxmedian{$x} = undef; }; } foreach my $x ( keys %maxmedian ){ if (defined $maxmedian{$x}) { $maxmedian{$x} *= 1.2; } else { $maxmedian{$x} = $max * 1.2; } $maxmedian{$x} = $cfg->{Presentation}{detail}{max_rtt} if $cfg->{Presentation}{detail}{max_rtt} and $maxmedian{$x} > $cfg->{Presentation}{detail}{max_rtt} }; return \%maxmedian; } sub smokecol ($) { my $count = shift; return [] unless $count > 2; my $half = $count/2; my @items; my $itop=$count; my $ibot=1; for (; $itop > $ibot; $itop--,$ibot++){ my $color = int(190/$half * ($half-$ibot))+50; push @items, "CDEF:smoke${ibot}=cp${ibot},UN,UNKN,cp${itop},cp${ibot},-,IF"; push @items, "AREA:cp${ibot}"; push @items, "STACK:smoke${ibot}#".(sprintf("%02x",$color) x 3); }; return \@items; } sub parse_datetime($){ my $in = shift; for ($in){ /^(\d+)$/ && do { my $value = $1; $value = time if $value > 2**32; return $value}; /^\s*(\d{4})-(\d{1,2})-(\d{1,2})(?:\s+(\d{1,2}):(\d{2})(?::(\d{2}))?)?\s*$/ && return POSIX::mktime($6||0,$5||0,$4||0,$3,$2-1,$1-1900,0,0,-1); /^now$/ && return time; /([ -:a-z0-9]+)/ && return $1; }; return time; } sub get_detail ($$$$;$){ # when drawing the detail page there are three modes for doing it # a) 's' classic with several static graphs on the page # b) 'n' navigator mode with one graph. below the graph one can specify the end time # and the length of the graph. # c) 'c' chart mode, one graph with a link to it's full page # d) 'a' ajax mode, generate image based on given url and dump in on stdout # my $cfg = shift; my $q = shift; my $tree = shift; my $open = shift; my $mode = shift || $q->param('displaymode') || 's'; my $phys_tree = $tree; my $phys_open = $open; if ($tree->{__tree_link}){ $phys_tree=$tree->{__tree_link}; $phys_open = $tree->{__real_path}; } if ($phys_tree->{host} and $phys_tree->{host} =~ m|^/|){ return Smokeping::Graphs::get_multi_detail($cfg,$q,$tree,$open,$mode); } # don't distinguish anymore ... tree is now phys_tree $tree = $phys_tree; my @slaves; if (not $tree->{nomasterpoll} or $tree->{nomasterpoll} eq 'no' or $mode eq 'a' or $mode eq 'n'){ @slaves = (""); }; if ($tree->{slaves} and $mode eq 's'){ push @slaves, split /\s+/,$tree->{slaves}; }; return "" if not defined $tree->{host} or 0 == @slaves; my $file = $mode eq 'c' ? (split(/~/, $open->[-1]))[0] : $open->[-1]; my @dirs = @{$phys_open}; pop @dirs; my $dir = ""; return "
ERROR: ".(join ".", @dirs)." has no probe defined
" unless $tree->{probe}; return "
ERROR: ".(join ".", @dirs)." $tree->{probe} is not known
" unless $cfg->{__probes}{$tree->{probe}}; my $probe = $cfg->{__probes}{$tree->{probe}}; my $ProbeDesc = $probe->ProbeDesc(); my $ProbeUnit = $probe->ProbeUnit(); my $pings = $probe->_pings($tree); my $step = $probe->step(); my $page; return "
ERROR: unknown displaymode $mode
" unless $mode =~ /^[snca]$/; for (@dirs) { $dir .= "/$_"; mkdir $cfg->{General}{imgcache}.$dir, 0755 unless -d $cfg->{General}{imgcache}.$dir; die "ERROR: creating $cfg->{General}{imgcache}$dir: $!\n" unless -d $cfg->{General}{imgcache}.$dir; } my $base_rrd = $cfg->{General}{datadir}.$dir."/${file}"; my $imgbase; my $imghref; my $max = {}; my @tasks; my %lastheight; if ($mode eq 's'){ # in nav mode there is only one graph, so the height calculation # is not necessary. $imgbase = $cfg->{General}{imgcache}."/".(join "/", @dirs)."/${file}"; $imghref = $cfg->{General}{imgurl}."/".(join "/", @dirs)."/${file}"; @tasks = @{$cfg->{Presentation}{detail}{_table}}; for my $slave (@slaves){ my $s = $slave ? "~$slave" : ""; if (open (HG,"<${imgbase}.maxheight$s")){ while (){ chomp; my @l = split / /; $lastheight{$s}{$l[0]} = $l[1]; } close HG; } $max->{$s} = findmax $cfg, $base_rrd.$s.".rrd"; if (open (HG,">${imgbase}.maxheight$s")){ foreach my $size (keys %{$max->{$s}}){ print HG "$s $max->{$s}{$size}\n"; } close HG; } } } elsif ($mode eq 'n' or $mode eq 'a') { my $slave = (split(/~/, $open->[-1]))[1]; my $name = $slave ? " as seen from ". $cfg->{Slaves}{$slave}{display_name} : ""; mkdir $cfg->{General}{imgcache}."/__navcache",0755 unless -d $cfg->{General}{imgcache}."/__navcache"; # remove old images after one hour my $pattern = $cfg->{General}{imgcache}."/__navcache/*.png"; for (glob $pattern){ unlink $_ if time - (stat $_)[9] > 3600; } if ($mode eq 'n') { $imgbase =$cfg->{General}{imgcache}."/__navcache/".time()."$$"; $imghref =$cfg->{General}{imgurl}."/__navcache/".time()."$$"; } else { my $serial = int(rand(2000)); $imgbase =$cfg->{General}{imgcache}."/__navcache/".$serial; $imghref =$cfg->{General}{imgurl}."/__navcache/".$serial; } $q->param('epoch_start',parse_datetime($q->param('start'))); $q->param('epoch_end',parse_datetime($q->param('end'))); @tasks = (["Navigator Graph".$name, parse_datetime($q->param('start')),parse_datetime($q->param('end'))]); my ($graphret,$xs,$ys) = RRDs::graph ("dummy", '--start', $tasks[0][1], '--end',$tasks[0][2], "DEF:maxping=${base_rrd}.rrd:median:AVERAGE", 'PRINT:maxping:MAX:%le' ); my $ERROR = RRDs::error(); return "
RRDtool did not understand your input: $ERROR.
" if $ERROR; my $val = $graphret->[0]; $val = 1 if $val =~ /nan/i; $max->{''} = { $tasks[0][1] => $val * 1.5 }; } else { # chart mode mkdir $cfg->{General}{imgcache}."/__chartscache",0755 unless -d $cfg->{General}{imgcache}."/__chartscache"; # remove old images after one hour my $pattern = $cfg->{General}{imgcache}."/__chartscache/*.png"; for (glob $pattern){ unlink $_ if time - (stat $_)[9] > 3600; } my $desc = join "/",@{$open}; @tasks = ([$desc , 3600]); $imgbase = $cfg->{General}{imgcache}."/__chartscache/".(join ".", @dirs).".${file}"; $imghref = $cfg->{General}{imgurl}."/__chartscache/".(join ".", @dirs).".${file}"; my ($graphret,$xs,$ys) = RRDs::graph ("dummy", '--start', time()-3600, '--end', time(), "DEF:maxping=${base_rrd}.rrd:median:AVERAGE", 'PRINT:maxping:MAX:%le' ); my $ERROR = RRDs::error(); return "
RRDtool did not understand your input: $ERROR.
" if $ERROR; my $val = $graphret->[0]; $val = 1 if $val =~ /nan/i; $max->{''} = { $tasks[0][1] => $val * 1.5 }; } my $smoke = $pings >= 3 ? smokecol $pings : [ 'COMMENT:(Not enough pings to draw any smoke.)\s', 'COMMENT:\s' ]; # one \s doesn't seem to be enough my @upargs; my @upsmoke; my %lc; my %lcback; if ( defined $cfg->{Presentation}{detail}{loss_colors}{_table} ) { for (@{$cfg->{Presentation}{detail}{loss_colors}{_table}}) { my ($num,$col,$txt) = @{$_}; $lc{$num} = [ $txt, "#".$col ]; } } else { my $p = $pings; %lc = (0 => ['0', '#26ff00'], 1 => ["1/$p", '#00b8ff'], 2 => ["2/$p", '#0059ff'], 3 => ["3/$p", '#5e00ff'], 4 => ["4/$p", '#7e00ff'], int($p/2) => [int($p/2)."/$p", '#dd00ff'], $p-1 => [($p-1)."/$p", '#ff0000'], ); }; # determine a more 'pastel' version of the ping colours; this is # used for the optional loss background colouring foreach my $key (keys %lc) { if ($key == 0) { $lcback{$key} = ""; next; } my $web = $lc{$key}[1]; my @rgb = Smokeping::Colorspace::web_to_rgb($web); my @hsl = Smokeping::Colorspace::rgb_to_hsl(@rgb); $hsl[2] = (1 - $hsl[2]) * (2/3) + $hsl[2]; @rgb = Smokeping::Colorspace::hsl_to_rgb(@hsl); $web = Smokeping::Colorspace::rgb_to_web(@rgb); $lcback{$key} = $web; } my %upt; if ( defined $cfg->{Presentation}{detail}{uptime_colors}{_table} ) { for (@{$cfg->{Presentation}{detail}{uptime_colors}{_table}}) { my ($num,$col,$txt) = @{$_}; $upt{$num} = [ $txt, "#".$col]; } } else { %upt = (3600 => ['<1h', '#FFD3D3'], 2*3600 => ['<2h', '#FFE4C7'], 6*3600 => ['<6h', '#FFF9BA'], 12*3600 => ['<12h','#F3FFC0'], 24*3600 => ['<1d', '#E1FFCC'], 7*24*3600 => ['<1w', '#BBFFCB'], 30*24*3600 => ['<1m', '#BAFFF5'], '1e100' => ['>1m', '#DAECFF'] ); } my $BS = ''; if ( $RRDs::VERSION >= 1.199908 ){ $ProbeDesc =~ s|:|\\:|g; $BS = '\\'; } for (@tasks) { my ($desc,$start,$end) = @{$_}; my %xs; my %ys; my $sigtime = ($end and $end =~ /^\d+$/) ? $end : time; my $date = $cfg->{Presentation}{detail}{strftime} ? POSIX::strftime($cfg->{Presentation}{detail}{strftime}, localtime($sigtime)) : scalar localtime($sigtime); if ( $RRDs::VERSION >= 1.199908 ){ $date =~ s|:|\\:|g; } $end ||= 'last'; $start = exp2seconds($start) if $mode =~ /[s]/; my $startstr = $start =~ /^\d+$/ ? POSIX::strftime("%Y-%m-%d %H:%M",localtime($mode eq 'n' ? $start : time-$start)) : $start; my $endstr = $end =~ /^\d+$/ ? POSIX::strftime("%Y-%m-%d %H:%M",localtime($mode eq 'n' ? $end : time)) : $end; my $realstart = ( $mode =~ /[sc]/ ? '-'.$start : $start); for my $slave (@slaves){ my $s = $slave ? "~$slave" : ""; my $swidth = $max->{$s}{$start} / $cfg->{Presentation}{detail}{height}; my $rrd = $base_rrd.$s.".rrd"; my $stddev = Smokeping::RRDhelpers::get_stddev($rrd,'median','AVERAGE',$realstart,$sigtime) || 0; my @median = ("DEF:median=${rrd}:median:AVERAGE", "CDEF:ploss=loss,$pings,/,100,*", "VDEF:avmed=median,AVERAGE", "CDEF:mesd=median,POP,avmed,$stddev,/", 'GPRINT:avmed:median rtt\: %.1lf %ss avg', 'GPRINT:median:MAX:%.1lf %ss max', 'GPRINT:median:MIN:%.1lf %ss min', 'GPRINT:median:LAST:%.1lf %ss now', sprintf('COMMENT:%.1f ms sd',$stddev*1000.0), 'GPRINT:mesd:AVERAGE:%.1lf %s am/s\l', "LINE1:median#202020" ); push @median, ( "GPRINT:ploss:AVERAGE:packet loss\\: %.2lf %% avg", "GPRINT:ploss:MAX:%.2lf %% max", "GPRINT:ploss:MIN:%.2lf %% min", 'GPRINT:ploss:LAST:%.2lf %% now\l', 'COMMENT:loss color\:' ); my @lossargs = (); my @losssmoke = (); my $last = -1; foreach my $loss (sort {$a <=> $b} keys %lc){ next if $loss >= $pings; my $lvar = $loss; $lvar =~ s/\./d/g ; push @median, ( "CDEF:me$lvar=loss,$last,GT,loss,$loss,LE,*,1,UNKN,IF,median,*", "CDEF:meL$lvar=me$lvar,$swidth,-", "CDEF:meH$lvar=me$lvar,0,*,$swidth,2,*,+", "AREA:meL$lvar", "STACK:meH$lvar$lc{$loss}[1]:$lc{$loss}[0]" # "LINE2:me$lvar$lc{$loss}[1]:$lc{$loss}[0]" ); if ($cfg->{Presentation}{detail}{loss_background} and $cfg->{Presentation}{detail}{loss_background} eq 'yes') { push @lossargs, ( "CDEF:lossbg$lvar=loss,$last,GT,loss,$loss,LE,*,INF,UNKN,IF", "AREA:lossbg$lvar$lcback{$loss}", ); push @losssmoke, ( "CDEF:lossbgs$lvar=loss,$last,GT,loss,$loss,LE,*,cp2,UNKN,IF", "AREA:lossbgs$lvar$lcback{$loss}", ); } $last = $loss; } # if we have uptime draw a colorful background or the graph showing the uptime my $cdir=dyndir($cfg)."/".(join "/", @dirs)."/"; if ((not defined $cfg->{Presentation}{detail}{loss_background} or $cfg->{Presentation}{detail}{loss_background} ne 'yes') && (-f "$cdir/${file}.adr")) { @upsmoke = (); @upargs = ("COMMENT:Link Up${BS}: ", "DEF:uptime=${base_rrd}.rrd:uptime:AVERAGE", "CDEF:duptime=uptime,86400,/", 'GPRINT:duptime:LAST: %0.1lf days ('); my $lastup = 0; foreach my $uptime (sort {$a <=> $b} keys %upt){ push @upargs, ( "CDEF:up$uptime=uptime,$lastup,GE,uptime,$uptime,LE,*,INF,UNKN,IF", "AREA:up$uptime$upt{$uptime}[1]:$upt{$uptime}[0]" ); push @upsmoke, ( "CDEF:ups$uptime=uptime,$lastup,GE,uptime,$uptime,LE,*,cp2,UNKN,IF", "AREA:ups$uptime$upt{$uptime}[1]" ); $lastup=$uptime; } push @upargs, 'COMMENT:)\l'; # map {print "$_
"} @upargs; }; my @log = (); push @log, "--logarithmic" if $cfg->{Presentation}{detail}{logarithmic} and $cfg->{Presentation}{detail}{logarithmic} eq 'yes'; my @lazy =(); @lazy = ('--lazy') if $mode eq 's' and $lastheight{$s} and $lastheight{$s}{$start} and $lastheight{$s}{$start} == $max->{$s}{$start}; my $timer_start = time(); my $from = $s ? " from $cfg->{Slaves}{$slave}{display_name}": ""; my @task = ("${imgbase}${s}_${end}_${start}.png", @lazy, '--start',$realstart, ($end ne 'last' ? ('--end',$end) : ()), '--height',$cfg->{Presentation}{detail}{height}, '--width',$cfg->{Presentation}{detail}{width}, '--title',$desc.$from, '--rigid','--upper-limit', $max->{$s}{$start}, @log, '--lower-limit',(@log ? ($max->{$s}{$start} > 0.01) ? '0.001' : '0.0001' : '0'), '--vertical-label',$ProbeUnit, '--imgformat','PNG', '--color', 'SHADEA#ffffff', '--color', 'SHADEB#ffffff', '--color', 'BACK#ffffff', '--color', 'CANVAS#ffffff', (map {"DEF:ping${_}=${rrd}:ping${_}:AVERAGE"} 1..$pings), (map {"CDEF:cp${_}=ping${_},$max->{$s}{$start},LT,ping${_},INF,IF"} 1..$pings), ("DEF:loss=${rrd}:loss:AVERAGE"), @upargs,# draw the uptime bg color @lossargs, # draw the loss bg color @$smoke, @upsmoke, # draw the rest of the uptime bg color @losssmoke, # draw the rest of the loss bg color @median,'COMMENT: \l', # Gray background for times when no data was collected, so they can # be distinguished from network being down. ( $cfg->{Presentation}{detail}{nodata_color} ? ( 'CDEF:nodata=loss,UN,INF,UNKN,IF', "AREA:nodata#$cfg->{Presentation}{detail}{nodata_color}" ): ()), 'HRULE:0#000000', "COMMENT:probe${BS}: $pings $ProbeDesc every ${step}s", 'COMMENT:end\: '.$date.'\j' ); # do_log ("***** begin task *****
"); # do_log (@task); # do_log ("***** end task *****
"); my $graphret; ($graphret,$xs{$s},$ys{$s}) = RRDs::graph @task; # die "
INFO:".join("
",@task)."
"; my $ERROR = RRDs::error(); if ($ERROR) { return "
ERROR: $ERROR
".join("
",@task)."
"; }; } if ($mode eq 'a'){ # ajax mode open my $img, "${imgbase}_${end}_${start}.png" or die "${imgbase}_${end}_${start}.png: $!"; binmode $img; print "Content-Type: image/png\n"; my $data; read($img,$data,(stat($img))[7]); close $img; print "Content-Length: ".length($data)."\n\n"; print $data; unlink "${imgbase}_${end}_${start}.png"; exit; } elsif ($mode eq 'n'){ # navigator mode # $page .= qq|
|; $page .= qq|| ; # $page .= "
"; $page .= $q->start_form(-method=>'POST', -id=>'range_form') . "

Time range: " . $q->hidden(-name=>'epoch_start',-id=>'epoch_start') . $q->hidden(-name=>'hierarchy',-id=>'hierarchy') . $q->hidden(-name=>'epoch_end',-id=>'epoch_end') . $q->hidden(-name=>'target',-id=>'target' ) . $q->hidden(-name=>'displaymode',-default=>$mode ) . $q->textfield(-name=>'start',-default=>$startstr) . "  to  ".$q->textfield(-name=>'end',-default=>$endstr) . " " . $q->submit(-name=>'Generate!') . "

" . $q->end_form(); } elsif ($mode eq 's') { # classic mode $startstr =~ s/\s/%20/g; $endstr =~ s/\s/%20/g; for my $slave (@slaves){ my $s = $slave ? "~$slave" : ""; $page .= "
"; # $page .= (time-$timer_start)."
"; # $page .= join " ",map {"'$_'"} @task; $page .= "
"; $page .= ( qq{param('target').$s.'">' . qq{}."" ); #" $page .= "
"; } } else { # chart mode $page .= "
"; my $href= (split /~/, (join ".", @$open))[0]; #/ # the link is 'slave free' $page .= ( qq{} . qq{}."" ); #" $page .= "
"; } } return $page; } sub get_charts ($$$){ my $cfg = shift; my $q = shift; my $open = shift; my $cache = $cfg->{__sortercache}; my $page = "

$cfg->{Presentation}{charts}{title}

"; return $page."

Waiting for initial data ...

" unless $cache; my %charts; for my $chart ( keys %{$cfg->{Presentation}{charts}} ) { next unless ref $cfg->{Presentation}{charts}{$chart} eq 'HASH'; $charts{$chart} = $cfg->{Presentation}{charts}{$chart}{__obj}->SortTree($cache->{$chart}); } if (not defined $open->[1]){ for my $chart ( keys %charts ){ $page .= "

$cfg->{Presentation}{charts}{$chart}{title}

\n"; if (not defined $charts{$chart}[0]){ $page .= "

No targets returned by the sorter.

" } else { my $tree = $cfg->{Targets}; my $chartentry = $charts{$chart}[0]; for (@{$chartentry->{open}}) { my ($host,$slave) = split(/~/, $_); die "ERROR: Section '$host' does not exist.\n" unless exists $tree->{$host}; last unless ref $tree->{$host} eq 'HASH'; $tree = $tree->{$host}; } $page .= get_detail($cfg,$q,$tree,$chartentry->{open},'c'); } } } else { my $chart = $open->[1]; $page = "

$cfg->{Presentation}{charts}{$chart}{title}

\n"; if (not defined $charts{$chart}[0]){ $page .= "

No targets returned by the sorter.

" } else { my $rank =1; for my $chartentry (@{$charts{$chart}}){ my $tree = $cfg->{Targets}; for (@{$chartentry->{open}}) { my ($host,$slave) = split(/~/, $_); die "ERROR: Section '$_' does not exist.\n" unless exists $tree->{$host}; last unless ref $tree->{$host} eq 'HASH'; $tree = $tree->{$host}; } $page .= "

$rank."; $page .= " ".sprintf($cfg->{Presentation}{charts}{$chart}{format},$chartentry->{value}) if ($cfg->{Presentation}{charts}{$chart}{format}); $page .= "

"; $rank++; $page .= get_detail($cfg,$q,$tree,$chartentry->{open},'c'); } } } return $page; } sub load_sortercache($){ my $cfg = shift; my %cache; my $found; for (glob "$cfg->{General}{datadir}/__sortercache/data*.storable"){ # kill old caches ... if ((time - (stat "$_")[9]) > $cfg->{Database}{step}*2){ unlink $_; next; } my $data = Storable::retrieve("$_"); for my $chart (keys %$data){ PATH: for my $path (keys %{$data->{$chart}}){ warn "Warning: Duplicate entry $chart/$path in sortercache\n" if defined $cache{$chart}{$path}; my $root = $cfg->{Targets}; for my $element (split /\//, $path){ if (ref $root eq 'HASH' and defined $root->{$element}){ $root = $root->{$element} } else { warn "Warning: Dropping $chart/$path from sortercache\n"; next PATH; } } $cache{$chart}{$path} = $data->{$chart}{$path} } } $found = 1; } return ( $found ? \%cache : undef ) } sub hierarchy_switcher($$){ my $q = shift; my $cfg = shift; my $print =$q->start_form(-name=>'hswitch',-method=>'get',-action=>$q->url(-relative=>1)); if ($cfg->{Presentation}{hierarchies}){ $print .= "
Hierarchy:
"; $print .= "
"; $print .= $q->popup_menu(-name=>'hierarchy', -onChange=>'hswitch.submit()', -values=>[0, sort map {ref $cfg->{Presentation}{hierarchies}{$_} eq 'HASH' ? $_ : () } keys %{$cfg->{Presentation}{hierarchies}}], -labels=>{0=>'Default Hierarchy', map {ref $cfg->{Presentation}{hierarchies}{$_} eq 'HASH' ? ($_ => $cfg->{Presentation}{hierarchies}{$_}{title} ) : () } keys %{$cfg->{Presentation}{hierarchies}} } ); $print .= "
"; } $print .= "
Filter:
"; $print .= "
"; $print .= $q->textfield (-name=>'filter', -onChange=>'hswitch.submit()', -size=>15, ); $print .= '
'.$q->end_form(); $print .= "

"; return $print; } sub display_webpage($$){ my $cfg = shift; my $q = shift; my ($path,$slave) = split(/~/,$q->param('target') || ''); my $hierarchy = $q->param('hierarchy'); die "ERROR: unknown hierarchy $hierarchy\n" if $hierarchy and not $cfg->{Presentation}{hierarchies}{$hierarchy}; my $open = [ (split /\./,$path||'') ]; my $open_orig = [@$open]; $open_orig->[-1] .= '~'.$slave if $slave; my($filter) = ($q->param('filter') and $q->param('filter') =~ m{([- _0-9a-zA-Z\+\*\(\)\|\^\[\]\.\$]+)}); my $tree = $cfg->{Targets}; if ($hierarchy){ $tree = $cfg->{__hierarchies}{$hierarchy}; }; my $menu_root = $tree; my $targets = $cfg->{Targets}; my $step = $cfg->{__probes}{$targets->{probe}}->step(); # lets see if the charts are opened my $charts = 0; $charts = 1 if defined $cfg->{Presentation}{charts} and $open->[0] and $open->[0] eq '_charts'; if ($charts and ( not defined $cfg->{__sortercache} or $cfg->{__sortercachekeeptime} < time )){ # die "ERROR: Chart $open->[1] does not exit.\n" # unless $cfg->{Presentation}{charts}{$open->[1]}; $cfg->{__sortercache} = load_sortercache $cfg; $cfg->{__sortercachekeeptime} = time + 60; }; if (not $charts){ for (@$open) { die "ERROR: Section '$_' does not exist (display webpage)." # .(join "", map {"$_=$ENV{$_}"} keys %ENV)."\n" unless exists $tree->{$_}; last unless ref $tree->{$_} eq 'HASH'; $tree = $tree->{$_}; } } gen_imgs($cfg); # create logos in imgcache my $readversion = "?"; $VERSION =~ /(\d+)\.(\d{3})(\d{3})/ and $readversion = sprintf("%d.%d.%d",$1,$2,$3); my $menu = $targets; if (defined $cfg->{Presentation}{charts} and not $hierarchy){ my $order = 1; $menu_root = { %{$menu_root}, _charts => { _order => -99, menu => $cfg->{Presentation}{charts}{menu}, map { $_ => { menu => $cfg->{Presentation}{charts}{$_}{menu}, _order => $order++ } } sort grep { ref $cfg->{Presentation}{charts}{$_} eq 'HASH' } keys %{$cfg->{Presentation}{charts}} } }; } my $hierarchy_arg = ''; if ($hierarchy){ $hierarchy_arg = 'hierarchy='.uri_escape($hierarchy).';'; }; my $filter_arg =''; if ($filter){ $filter_arg = 'filter='.uri_escape($filter).';'; }; # if we are in a hierarchy, recover the original path my $display_tree = $tree->{__tree_link} ? $tree->{__tree_link} : $tree; my $page = fill_template ($cfg->{Presentation}{template}, { menu => hierarchy_switcher($q,$cfg). target_menu( $menu_root, [@$open], #copy this because it gets changed cgiurl($q, $cfg) ."?${hierarchy_arg}${filter_arg}target=", $filter ), title => $charts ? "" : $display_tree->{title}, remark => $charts ? "" : ($display_tree->{remark} || ''), overview => $charts ? get_charts($cfg,$q,$open) : get_overview( $cfg,$q,$tree,$open), body => $charts ? "" : get_detail( $cfg,$q,$tree,$open_orig ), target_ip => $charts ? "" : ($display_tree->{host} || ''), owner => $cfg->{General}{owner}, contact => $cfg->{General}{contact}, author => 'Tobi Oetiker and Niko Tyni', smokeping => 'SmokePing-'.$readversion.'', step => $step, rrdlogo => '', smokelogo => '', } ); my $expi = $cfg->{Database}{step} > 120 ? $cfg->{Database}{step} : 120; print $q->header(-type=>'text/html', -expires=>'+'.$expi.'s', -charset=> ( $cfg->{Presentation}{charset} || 'iso-8859-15'), -Content_length => length($page), ); print $page || "ERROR: Reading page template".$cfg->{Presentation}{template}.""; } # fetch all data. sub run_probes($$) { my $probes = shift; my $justthisprobe = shift; if (defined $justthisprobe) { $probes->{$justthisprobe}->ping(); } else { foreach my $probe (keys %{$probes}) { $probes->{$probe}->ping(); } } } # report probe status sub report_probes($$) { my $probes = shift; my $justthisprobe = shift; if (defined $justthisprobe) { $probes->{$justthisprobe}->report(); } else { foreach my $probe (keys %{$probes}){ $probes->{$probe}->report(); } } } sub load_sorters($){ my $subcfg = shift; foreach my $key ( keys %{$subcfg} ) { my $x = $subcfg->{$key}; next unless ref $x eq 'HASH'; $x->{sorter} =~ /(\S+)\((.+)\)/; my $sorter = $1; my $arg = $2; die "ERROR: sorter $sorter: all sorters start with a capital letter\n" unless $sorter =~ /^[A-Z]/; eval 'require Smokeping::sorters::'.$sorter; die "Sorter '$sorter' could not be loaded: $@\n" if $@; $x->{__obj} = eval "Smokeping::sorters::$sorter->new($arg)"; die "ERROR: sorter $sorter: instantiation with Smokeping::sorters::$sorter->new($arg): $@\n" if $@; } } sub update_sortercache($$$$$){ my $cfg = shift; return unless $cfg->{Presentation}{charts}; my $cache = shift; my $path = shift; my $base = $cfg->{General}{datadir}; $path =~ s/^$base\/?//; my @updates = map {/U/ ? undef : 0.0+$_ } split /:/, shift; my $alert = shift; my %info; $info{uptime} = shift @updates; $info{loss} = shift @updates; $info{median} = shift @updates; $info{alert} = $alert; $info{pings} = \@updates; foreach my $chart ( keys %{$cfg->{Presentation}{charts}} ) { next unless ref $cfg->{Presentation}{charts}{$chart} eq 'HASH'; $cache->{$chart}{$path} = $cfg->{Presentation}{charts}{$chart}{__obj}->CalcValue(\%info); } } sub save_sortercache($$$){ my $cfg = shift; my $cache = shift; my $probe = shift; return unless $cfg->{Presentation}{charts}; my $dir = $cfg->{General}{datadir}."/__sortercache"; my $ext = ''; $ext .= $probe if $probe; $ext .= join "",@{$opt{filter}} if @{$opt{filter}}; $ext =~ s/[^-_=0-9a-z]/_/gi; $ext = ".$ext" if $ext; mkdir $dir,0755 unless -d $dir; Storable::store ($cache, "$dir/new$ext"); rename "$dir/new$ext","$dir/data$ext.storable" } sub check_alerts { my $cfg = shift; my $tree = shift; my $pings = shift; my $name = shift; my $prop = shift; my $loss = shift; my $rtt = shift; my $slave = shift; my $gotalert; my $s = ""; if ($slave) { $s = '~'.$slave } if ( $tree->{alerts} ) { my $priority_done; $tree->{'stack'.$s} = {loss=>['S'],rtt=>['S']} unless defined $tree->{'stack'.$s}; my $x = $tree->{'stack'.$s}; $loss = undef if $loss eq 'U'; my $lossprct = $loss * 100 / $pings; $rtt = undef if $rtt eq 'U'; push @{$x->{loss}}, $lossprct; push @{$x->{rtt}}, $rtt; if (scalar @{$x->{loss}} > $tree->{fetchlength}){ shift @{$x->{loss}}; shift @{$x->{rtt}}; } for (sort { ($cfg->{Alerts}{$a}{priority}||0) <=> ($cfg->{Alerts}{$b}{priority}||0)} @{$tree->{alerts}}) { my $alert = $cfg->{Alerts}{$_}; if ( not $alert ) { do_log "WARNING: Empty alert in ".(join ",", @{$tree->{alerts}})." ($name)\n"; next; }; if ( ref $alert->{sub} ne 'CODE' ) { do_log "WARNING: Alert '$_' did not resolve to a Sub Ref. Skipping\n"; next; }; my $prevmatch = $tree->{'prevmatch'.$s}{$_} || 0; # add the current state of an edge triggered alert to the # data passed into a matcher, which allows for somewhat # more intelligent alerting due to state awareness. $x->{prevmatch} = $prevmatch; my $priority = $alert->{priority}; my $match = &{$alert->{sub}}($x) || 0; # Avgratio returns undef $gotalert = $match unless $gotalert; my $edgetrigger = $alert->{edgetrigger} eq 'yes'; my $what; if ($edgetrigger and $prevmatch != $match) { $what = ($prevmatch == 0 ? "was raised" : "was cleared"); } if (not $edgetrigger and $match) { $what = "is active"; } if ($what and (not defined $priority or not defined $priority_done )) { $priority_done = $priority if $priority and not $priority_done; # send something my $from; my $line = "$name/$prop"; my $base = $cfg->{General}{datadir}; $line =~ s|^$base/||; $line =~ s|/host$||; $line =~ s|/|.|g; $line .= "[from $slave]" if $slave; do_log("Alert $_ $what for $line"); my $urlline = $line; $urlline = $cfg->{General}{cgiurl}."?target=".$line; my $loss = "loss: ".join ", ",map {defined $_ ? (/^\d/ ? sprintf "%.0f%%", $_ :$_):"U" } @{$x->{loss}}; my $rtt = "rtt: ".join ", ",map {defined $_ ? (/^\d/ ? sprintf "%.0fms", $_*1000 :$_):"U" } @{$x->{rtt}}; my $time = time; my @stamp = localtime($time); my $stamp = localtime($time); my @to; foreach my $addr (map {$_ ? (split /\s*,\s*/,$_) : ()} $cfg->{Alerts}{to},$tree->{alertee},$alert->{to}){ next unless $addr; if ( $addr =~ /^\|(.+)/) { my $cmd = $1; if ($edgetrigger) { system $cmd,$_,$line,$loss,$rtt,$tree->{host}, ($what =~/raise/); } else { system $cmd,$_,$line,$loss,$rtt,$tree->{host}; } } elsif ( $addr =~ /^snpp:(.+)/ ) { sendsnpp $1, <{comment} $_ $what on $line $loss $rtt SNPPALERT } else { push @to, $addr; } }; if (@to){ my $default_mail = < <##WHAT##> on <##LINE##> <##STAMP##> Alert "<##ALERT##>" <##WHAT##> for <##URL##> Pattern ------- <##PAT##> Data (old --> now) ------------------ <##LOSS##> <##RTT##> Comment ------- <##COMMENT##> DOC my $mail = fill_template($alert->{mailtemplate}, { ALERT => $_, WHAT => $what, LINE => $line, URL => $urlline, STAMP => $stamp, PAT => $alert->{pattern}, LOSS => $loss, RTT => $rtt, COMMENT => $alert->{comment} },$default_mail) || "Subject: smokeping failed to open mailtemplate '$alert->{mailtemplate}'\n\nsee subject\n"; my $rfc2822stamp = strftime("%a, %e %b %Y %H:%M:%S %z", @stamp); my $to = join ",",@to; sendmail $cfg->{Alerts}{from},$to, <{Alerts}{from} Date: $rfc2822stamp $mail ALERT } } else { do_debuglog("Alert \"$_\": no match for target $name\n"); } $tree->{'prevmatch'.$s}{$_} = $match; } } # end alerts return $gotalert; } sub update_rrds($$$$$$); sub update_rrds($$$$$$) { my $cfg = shift; my $probes = shift; my $tree = shift; my $name = shift; my $justthisprobe = shift; # if defined, update only the targets probed by this probe my $sortercache = shift; my $probe = $tree->{probe}; foreach my $prop (keys %{$tree}) { if (ref $tree->{$prop} eq 'HASH'){ update_rrds $cfg, $probes, $tree->{$prop}, $name."/$prop", $justthisprobe, $sortercache; } # if we are looking down a branche where no probe property is set there is no sense # in further exploring it next unless defined $probe; next if defined $justthisprobe and $probe ne $justthisprobe; my $probeobj = $probes->{$probe}; my $pings = $probeobj->_pings($tree); if ($prop eq 'host' and check_filter($cfg,$name) and $tree->{$prop} !~ m|^/|) { # skip multihost my @updates; if (not $tree->{nomasterpoll} or $tree->{nomasterpoll} eq 'no'){ @updates = ([ "", time, $probeobj->rrdupdate_string($tree) ]); } if ($tree->{slaves}){ my @slaves = split(/\s+/, $tree->{slaves}); foreach my $slave (@slaves) { my $lines = Smokeping::Master::get_slaveupdates($cfg, $name, $slave); push @updates, @$lines; } #foreach my $checkslave } for my $update (sort {$a->[1] <=> $b->[1]} @updates){ # make sure we put the updates in chronological order in my $s = $update->[0] ? "~".$update->[0] : ""; if ( $tree->{rawlog} ){ my $file = POSIX::strftime $tree->{rawlog},localtime($update->[1]); if (open LOG,">>$name$s.$file.csv"){ print LOG time,"\t",join("\t",split /:/,$update->[2]),"\n"; close LOG; } else { do_log "Warning: failed to open $name$s.$file for logging: $!\n"; } } my @rrdupdate = ( $name.$s.".rrd", '--template', ( join ":", "uptime", "loss", "median", map { "ping${_}" } 1..$pings ), $update->[1].":".$update->[2] ); do_debuglog("Calling RRDs::update(@rrdupdate)"); RRDs::update ( @rrdupdate ); my $ERROR = RRDs::error(); do_log "RRDs::update ERROR: $ERROR\n" if $ERROR; # check alerts my ($loss,$rtt) = (split /:/, $update->[2])[1,2]; my $gotalert = check_alerts $cfg,$tree,$pings,$name,$prop,$loss,$rtt,$update->[0]; update_sortercache $cfg,$sortercache,$name.$s,$update->[2],$gotalert; } } } } sub _deepcopy { # this handles circular references on consecutive levels, # but breaks if there are any levels in between my $what = shift; return $what unless ref $what; for (ref $what) { /^ARRAY$/ and return [ map { $_ eq $what ? $_ : _deepcopy($_) } @$what ]; /^HASH$/ and return { map { $_ => $what->{$_} eq $what ? $what->{$_} : _deepcopy($what->{$_}) } keys %$what }; /^CODE$/ and return $what; # we don't need to copy the subs } die "Cannot _deepcopy reference type @{[ref $what]}"; } sub get_parser () { # The _dyn() stuff here is quite confusing, so here's a walkthrough: # 1 Probe is defined in the Probes section # 1.1 _dyn is called for the section to add the probe- and target-specific # vars into the grammar for this section and its subsections (subprobes) # 1.2 A _dyn sub is installed for all mandatory target-specific variables so # that they are made non-mandatory in the Targets section if they are # specified here. The %storedtargetvars hash holds this information. # 1.3 If a probe section has any subsections (subprobes) defined, the main # section turns into a template that just offers default values for # the subprobes. Because of this a _dyn sub is installed for subprobe # sections that makes any mandatory variables in the main section non-mandatory. # 1.4 A similar _dyn sub as in 1.2 is installed for the subprobe target-specific # variables as well. # 2 Probe is selected in the Targets section top # 2.1 _dyn is called for the section to add the probe- and target-specific # vars into the grammar for this section and its subsections. Any _default # values for the vars are removed, as they will be propagated from the Probes # section. # 2.2 Another _dyn sub is installed for the 'probe' variable in target subsections # that behaves as 2.1 # 2.3 A _dyn sub is installed for the 'host' variable that makes the mandatory # variables mandatory only in those sections that have a 'host' setting. # 2.4 A _sub sub is installed for the 'probe' variable in target subsections that # bombs out if 'probe' is defined after any variables that depend on the # current 'probe' setting. my $KEYD_RE = '[-_0-9a-zA-Z]+'; my $KEYDD_RE = '[-_0-9a-zA-Z.]+'; my $PROBE_RE = '[A-Z][a-zA-Z]+'; my $e = "="; my %knownprobes; # the probes encountered so far # get a list of available probes for _dyndoc sections my $libdir = find_libdir(); my $probedir = $libdir . "/Smokeping/probes"; my $matcherdir = $libdir . "/Smokeping/matchers"; my $sorterdir = $libdir . "/Smokeping/sorters"; my $probelist; my @matcherlist; my @sorterlist; die("Can't find probe module directory") unless defined $probedir; opendir(D, $probedir) or die("opendir $probedir: $!"); for (readdir D) { next unless s/\.pm$//; next unless /^$PROBE_RE/; $probelist->{$_} = "(See the L for details about each variable.)"; } closedir D; die("Can't find matcher module directory") unless defined $matcherdir; opendir(D, $matcherdir) or die("opendir $matcherdir: $!"); for (sort readdir D) { next unless /[A-Z]/; next unless s/\.pm$//; push @matcherlist, $_; } die("Can't find sorter module directory") unless defined $sorterdir; opendir(D, $sorterdir) or die("opendir $sorterdir: $!"); for (sort readdir D) { next unless /[A-Z]/; next unless s/\.pm$//; push @sorterlist, $_; } # The target-specific vars of each probe # We need to store them to relay information from Probes section to Target section # see 1.2 above my %storedtargetvars; # the part of target section syntax that doesn't depend on the selected probe my $TARGETCOMMON; # predeclare self-referencing structures # the common variables my $TARGETCOMMONVARS = [ qw (probe menu title alerts note email host remark rawlog alertee slaves menuextra parents hide nomasterpoll) ]; $TARGETCOMMON = { _vars => $TARGETCOMMONVARS, _inherited=> [ qw (probe alerts alertee slaves menuextra nomasterpoll) ], _sections => [ "/$KEYD_RE/" ], _recursive=> [ "/$KEYD_RE/" ], _sub => sub { my $val = shift; return "PROBE_CONF sections are neither needed nor supported any longer. Please see the smokeping_upgrade document." if $val eq 'PROBE_CONF'; return undef; }, "/$KEYD_RE/" => {}, _order => 1, _varlist => 1, _doc => < { _doc => 'Comma separated list of alert names', _re => '([^\s,]+(,[^\s,]+)*)?', _re_error => 'Comma separated list of alert names', }, hide => { _doc => <