#! /usr/bin/perl -Tw # $Id: whopings.pl,v 1.18 2005/05/21 11:42:47 mca1001 Exp $ $vsn=q$Revision: 1.18 $; $ENV{'PATH'}="/bin:/usr/bin:/sbin:/usr/sbin"; $ENV{'ENV'} = ''; $ENV{'IFS'} = ''; require 5.004; use Net::Ping; use Net::DNS; use Time::Local; use Socket; use FileHandle; use IPC::Open2; use strict; use vars qw( %info @fieldnames @maildomains @domains %progpath $vsn); $| = 1; @maildomains = ( qr'@grantadesign\.com$'i, qr'@granta\.co\.uk$'i, qr/[@.]granta\.internal$/i, ); @domains = qw(granta.internal); %progpath = ( arp => '/usr/sbin/arp', nmblookup => '/usr/bin/nmblookup', fping => '/usr/bin/fping', ); ## HTML header & footer #################################################### my $date = scalar localtime; print <<"MAGIC"; Content-type: text/html What's on the network today?

Local Machine Details

Generated at $date

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; either version 2 of the License, or (at your option) any later version.

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. GPLish # ############################################################################## # %info: key = IP addr, value = { key = fieldname, value = HTML string } # Fieldnames should all be in @fieldnames. They're printed in that # order too, after the IP address. If you don't add them yourself, # they'll come out in no particular order. Fields matching /^_/ aren't # displayed. system("cp", "/home/matthew/cvswork-relapse/cgi/whopings.pl", "/home/matthew/public_html/cgi-bin"); $SIG{__DIE__} = sub { print "

Died with error '@_'

\n"; exit 1; }; $SIG{__WARN__} = sub { print "

Warning: @_

\n"; }; # sanity check on this before we get too involved foreach my $p (keys %progpath) { die "$p program '$progpath{$p}' is not an executable" unless -x $progpath{$p}; } if (0) { # old broken stuff my ($domain, $ipref); print "For each computer in $domain, I send a ping:

\n"; scan_zone($ipref, $domain); $ipref = read_leases('/etc/dhcpd.leases'); print "

For each computer with a DHCP lease on the network, I send a ping:

\n"; scan_zone($ipref, $domain); } #----------------------------------------------------------------------------- foreach my $domain (@domains) { print "Zone transfer for $domain
\n"; slurp_dns($domain); } # Read DHCP leases file, if available print "(DHCP leases file not implemented)
\n"; # Ping everything, and the rest of the subnet too print "Ping scan
\n"; ping_scan(); # ick, has 10.0.0.0/24 hard coded # "/sbin/arp" and put hwether addresses to IPs, then highlight broken ones print "Arp check
\n"; arpcheck(); # Reverse DNS pass: check all IPs have a 'Name' defined, maybe do a # lookup on all of them anyway. print "(Reverse DNS not implemented)
\n"; # Parallel "nmblookup -A" on anything that pings # OK, it's serial, but parallel would be so much better! if (0) { print "SMB probe
\n"; SMBprobe(); } else { warn "skipping SMB probe because it's slow\n"; } print "

Finished in ".(time() - $^T)."sec.\n"; @fieldnames = qw(Name Status); ## Write the headings and data table ####################################### { my $debug = 0; my %validfields; @validfields{@fieldnames} = (); foreach my $ip (keys %info) { foreach my $f (keys %{ $info{$ip} }) { if ($f =~ /^_/ && !$debug) { # these are tmp values delete $info{$ip}->{$f}; next; } next if exists $validfields{$f}; push @fieldnames, $f; undef $validfields{$f}; } } } print('', "\n\n", (map { " \n" } "IP addr", @fieldnames), "\n"); foreach my $ip (sort by_ip keys %info) { my $i = $info{$ip}; print " \n \n"; foreach my $f (@fieldnames) { if (!defined $i->{$f}) { print " \n"; } elsif ($i->{$f} =~ /^{$f}; } else { print " \n"; } } print " \n"; } print "
$_
$ip ", $i->{$f}, "
\n$footer"; exit 0; ############################################################################## sub ping_scan # no args, no return. Updates %info { my %status; # Things to check, currently unknown # @status{keys %info} = (); for (my $i=1; $i< 90 # 255 ; $i++) { my $ip = "10.0.0.$i"; if (defined $info{$ip} && defined $info{$ip}->{'Status'}) { delete $status{$ip}; } else { undef $status{$ip}; } } # Start the pinger & wait for its output. This all does blocking # stuff at the moment, it's likely to cause problems. my $pid = open2(*PingIn, *PingOut, "$progpath{'fping'} -a -r 2 -i 10 2>/dev/null"); print PingOut join "\n", sort by_ip keys %status; close PingOut; my @output = ; close PingIn; chomp @output; @status{@output} = (1) x @output; foreach my $ip (keys %status) { next unless $status{$ip} || defined $info{$ip}; # ignore unused IPs $info{$ip}->{'_up'} = 1 if $status{$ip}; my $state = $status{$ip} ? 'Up' : 'Down'; my $col = ""; if (defined $info{$ip}->{'DHCP config'}) { $col = $status{$ip} ? 'green' : 'red'; # normal, should be active } else { $col = $status{$ip} ? 'lightgreen' : 'pink'; # should be inactive } $state = "$state"; $info{$ip} = {} unless defined $info{$ip}; $info{$ip}->{'Status'} = $state unless defined $info{$ip}->{'Status'}; } # my @list = `perl -e 'for(my $i=1; $i<255; $i++) { print "10.0.0.$i\n" }' | fping -a -r 2 -i 10 2>/dev/null`; # *cough* # my @list = `nmap -sP -n -T insane 10.0.0.0/24`; } sub arpcheck # no args, no return. Updates %info { my @arp = `$progpath{'arp'} -n`; my $hdr = shift @arp; die "Arp info header mismatch, got \"$hdr\"" unless $hdr =~ /^address\s+hwtype\s+hwaddress\s+flags\s+mask\s+iface$/i; foreach my $a (@arp) { chomp $a; my $orig = $a; die "Can't see known interface in arp line '$orig'" unless $a =~ s/\s+((?:eth|ppp)\d+)\s*$//; my $dev = $1; # ignore the device because I don't deal with multihomed boxes yet die "Can't see IP addr in line '$orig'" unless $a =~ s/^([\d.:]+)\s+//; my $ip = $1; next if $a =~ /^\s*$incomplete$\s*$/; # dull die "Don't understand arp line '$orig'" unless $a =~ m{^\s*ether\s+([0-9A-F:]{17})}i; my $hw = $1; if (defined $info{$ip}->{'DHCP config'}) { my $dhcp = \ $info{$ip}->{'DHCP config'}; if (not $$dhcp =~ s!$hw!$hw!i) { $info{$ip}->{'HWether'} = $hw; die "Oops, didn't expect table cell on dhcpconfig '$$dhcp'" if $$dhcp =~ /$$dhcp"; } } else { $info{$ip}->{'HWether'} = $hw; } } } sub SMBprobe # no args, no return. Updates %info { foreach my $ip (keys %info) { next unless $info{$ip}->{'_up'}; my $nmb = `$progpath{'nmblookup'} -A $ip 2>&1`; my @names = $nmb =~ /^\s+(\S+)/mg; # sod the number bitsy { # uniquify & remove dull entries my %names; @names{@names} = (); my $uname = uc($info{$ip}->{'_name'}); delete @names{( $uname, $uname.'$', "IS~$uname", )}; @names=keys %names; } $info{$ip}->{'SMB'} = join ", ", @names if @names; } } sub slurp_dns # args = (domain-name) #| Fills data in global %info { my $domain = shift; my $res = new Net::DNS::Resolver; # we're assuming this is pretty fast... my @zone = $res->axfr($domain); my %by_name; # key=name, value = hash of data to put in %info. # This data should also include 'ip', which will be removed as the # data is copied. Entries which are arrayrefs are written are # joined with the first element. # Oh, and 'Name' is added, unless already present. my $listpoke = sub { # args = (infoname, infotype, separator, info) my ($name, $type, $sep, $info) = @_; $by_name{$name} = {} unless defined $by_name{$name}; my $n = $by_name{$name}; $n->{$type} = [$sep] unless defined $n->{$type}; push @{ $n->{$type} }, $info; }; # Slurp foreach my $rr (@zone) { my ($t, $name) = ($rr->type, $rr->name); if ($name !~ s@\.?$domain$@@i) { warn("Can't lop .$domain from $name in ".$rr->string. ", will ignore it"); next; } if ($name =~ m,^(?:static-lease|bcast|dynamic-lease)$,i) { warn "Ignoring DHCP control RR:\n ".$rr->string."\n"; next; } $by_name{$name} = {} unless defined $by_name{$name}; my $nh = $by_name{$name}; if ($t eq 'SOA' || $t eq 'NS' || $t eq 'MX') { next; } elsif ($t eq 'A') { die "Can't deal with multi-homed machines yet, in ".$rr->string if defined $nh->{'ip'}; $nh->{'ip'} = $rr->address; } elsif ($t eq 'CNAME') { my $cname = $rr->cname; if ($cname !~ s@\.?$domain$@@i) { warn("Can't lop .$domain from CNAME $name in ".$rr->string. ", will ignore it"); next; } $listpoke->($cname, 'aka.', ", ", $name); } elsif ($t eq 'TXT') { my $txt = $rr->txtdata; if ($txt =~ /^hwether=(.*)/) { $listpoke->($name, 'DHCP config', "
\n", $txt); } elsif ($txt =~ /^\[(.*)\](.*)/ && !defined $nh->{'Name'}) { # These are of the form "[Mr Hostname the thingummy's wotsit]" # Insert them, formatted nicely, in the name field. $nh->{'Name'} = comicalname($name, $1); } else { # other misc text info, and "spare" comical names $listpoke->($name, 'Other', "

$_
$ip		", $i->{$f}, "

\n", $txt); } } elsif ($t eq 'RP') { my $e = $rr->mbox; # Currently we ignore the $rr->txtdname info. Should probably hyperlink... if ($e eq '.' || $e eq '') { $listpoke->($name, 'Owner', "
\n", "[not specified]"); } else { $e =~ s/(?($name, 'Owner', "
\n", "$print_e"); } } elsif ($t eq 'WKS') { # Ignore Well Known Server map for now, partly because # Net::DNS isn't helpful here print "Ignored WKS '".$rr->string."'
\n"; # Might be nice to try to pull out virtually hosted # webservers, from WKS entries on CNAMEs? } else { warn "Unknown RR '".$rr->string."'"; next; } } #^^TODO: argh, some of these (TXT, fancy name?) should be quoted... # Save foreach my $name (keys %by_name) { # No entries would be a CNAME or something next unless scalar keys %{ $by_name{$name} }; my $ip = $by_name{$name}->{'ip'}; if (!defined $ip) { next if $name =~ /^spare/i; $ip = "unusedname:$name"; # this will cause warnings at sort-time } # Insert data into the server list my $i; if (defined $info{$ip}) { die "Wasn't expecting to have to shuffle data for $name=$ip"; $i = $info{$ip}; } else { $i = $info{$ip} = $by_name{$name}; } # Fix missing/spare fields delete $i->{'ip'}; $i->{'Name'} = $name unless defined $i->{'Name'}; $i->{'_name'} = $name; # remains undecorated if (( defined $ENV{'HTTP_HOST'} and lc("$name.$domain") eq lc($ENV{'HTTP_HOST'})) || ( defined $ENV{'SERVER_NAME'} and lc("$name.$domain") eq lc($ENV{'SERVER_NAME'})) ) { $info{$ip}->{'_up'} = "self"; $i->{'Status'} = 'Self'; } # Join arrays foreach my $f (keys %$i) { if (ref($i->{$f}) eq 'ARRAY') { my $j = shift @{ $i->{$f} }; $i->{$f} = join $j, @{ $i->{$f} }; } } } } # has_httpd($ip, $dName, "$plain_name.$domain") : sub comicalname($$) # args = (dnsname, description) { my ($plain_name, $descr) = @_; my $namepat = $plain_name; $namepat =~ s@[-_ ]@\[-_ \]@g; if ($descr =~ m@^(.*?)($namepat)(.*)$@is) { my ($pre, $Name, $suff) = ($1, $2, $3); my $dName = $Name; $dName =~ tr/ /-/; my ($f1, $f2) = ("", ""); return join "", ($f1, $pre, $f2, "", $dName, "", $f1, $suff, $f2); } else { return $descr . "
(no match for '$namepat'...?)"; } } sub read_leases # args = (filename) #| Return (hashref-of-IPs) { # hash key = IP address, value = [name, comment] my $file = shift; die "Can't open DHCP lease list '$file': $!" unless open LF, "<$file"; my %ip; my %tmp = (); my $now = time(); while () { chomp; if (/^lease\s+(\d+\.\d+\.\d+\.\d+)\s+\{$/i) { die "Overlapping/nested lease blocks in $file: $tmp{'lease'} is not closed before $1" if defined $tmp{'lease'}; $tmp{'lease'} = $1; } elsif (/^\s+(\w+)\s+(.+);$/) { die "Data line '$_' outside a lease block" unless defined $tmp{'lease'}; $tmp{$1} = $2; } elsif ($_ eq '}') { $tmp{'hardware'} = '[unknown]' unless defined $tmp{'hardware'}; my $list = $ip{$tmp{'lease'}} = [$tmp{'hardware'}]; delete @tmp{('lease', 'hardware')}; my @comments = (); if (defined $tmp{'ends'}) { my $then = $tmp{'ends'}; die "Can't parse end time '$then'" unless $then =~ m@(\d{4})/(\d{1,2})/(\d{1,2})\s+(\d{2}):(\d{2}):(\d{2})@; $then = timelocal($6,$5,$4, $3,$2-1,$1-1900); $tmp{'ends'} .= " (dead)" if $then < $now; } foreach (reverse sort keys %tmp) { next if $_ eq 'uid'; push @comments, "$_ $tmp{$_}"; } push @$list, (join "\n", @comments); %tmp = (); } else { die "What does a '$_' mean?"; } } close LF; return \%ip; } # a 'sort' function, not necessarily built for efficiency or correctness! sub by_ip { (split '\.',$a)[3] <=> (split '\.', $b)[3] or $a cmp $b } sub scan_zone # args = (\%ip, $domain) { my $pinger; $pinger = Net::Ping->new('icmp', 0.1) if $> == 0; my %ip = %{shift @_}; my $domain = shift; print "\n"; my $ip; foreach $ip (sort by_ip keys %ip) { my ($name,$comment) = @{$ip{$ip}}; my $state; my $online = 0; if ((defined $ENV{'HTTP_HOST'} and lc($name) eq lc($ENV{'HTTP_HOST'})) || (defined $ENV{'SERVER_NAME'} and lc($name) eq lc($ENV{'SERVER_NAME'})) ) { $state = "green>I'm here"; $online = 1; } elsif ($name =~ s/^ethernet \w+:\w+:\w+:\w+:\w+:\w+:\w+:\w+:\w+[a-f\d:]+/(stupid)/ && $comment =~ /\bDEAD\b/i ) { $state = "lightgrey> "; $comment = '(dead)'; next; # we don't need this rubbish } else { if (defined $pinger) { $online = $pinger -> ping($ip); $state = ($online ? "green>Up" : "red>Down"); } else { $state = "red>Unknown"; } } if ($comment =~ /\bDEAD\b/i) { $state =~ s/^red>/pink>/; $state =~ s/^green>/lightgreen>/; } my $plain_name = $name; my $namep = $name; $namep =~ s@[-_ ]@\[-_ \]@g; if ($comment =~ m@^(.*?)($namep)(.*)$@is) { my ($pre, $Name, $suff) = ($1, $2, $3); my $dName = $Name; $dName =~ tr/ /-/; $dName = "$dName"; $dName = ($online ? has_httpd($ip, $dName, "$plain_name.$domain") : $dName); if ($pre =~ m@\[@ && $suff =~ m@\]@) { my (@pre, @suff); @pre = ($pre =~ m@^(.*)\[(.*)$@si ? ($1, $2) : ($pre, "")); @suff = ($suff =~ m@^(.*)\](.*)$@si ? ($1, $2) : ($suff,"")); foreach ($pre[1], $suff[0]) { $_ = "$_" if $_ ne ''; } $comment = join "", $pre[0], $suff[1]; $name = join "", $pre[1], $dName, $suff[0]; } else { $comment = join "", $pre, $Name, $suff; $name = $dName; } } else { $name = "$name" unless $name =~ m@[()\s]@; $name = has_httpd($ip, $name, "$plain_name.$domain") if $online; } $comment =~ s@\n@
@g; $comment =~ s%(\S+)(\@[a-zA-Z0-9.-]+)%$1%; print "\n"; } $pinger->close(); } sub has_httpd # args = (ip, anchor-text, FQDN) #| Return a plain name or a hyperlinked name #| nb. I qualify the domain with .granta.internal for consistency over portability! { # this should tickle the machine and see if it laughs but I can't be bothered my ($ip, $txt, $fullname) = (shift, shift, shift); if (TCPprobe($ip, 80)) { return "$txt"; } elsif (TCPprobe($ip, 443)) { return "$txt"; } return $txt; } sub TCPprobe # args = (name, numeric-port) #| Return true/false for whether something is listening on the port # Better make sure it's up first, otherwise we wait for a timeout! { my ($remote, $port) = (shift, shift); my $iaddr = inet_aton($remote) || die "no host: $remote"; my $paddr = sockaddr_in($port, $iaddr); my $proto = getprotobyname('tcp'); socket(POKE, PF_INET, SOCK_STREAM, $proto) || die "socket to $remote: $!"; if (connect(POKE, $paddr)) { close POKE || die "close on $remote: $!"; return 1; } return 0; }

IP Name Status Comment
$ip $name $comment