#!/usr/bin/perl -ws
# Created by Ben Okopnik on Thu Jun 28 09:11:52 EDT 2007
#
# Copyright (C) 2007 Ben Okopnik <ben@okopnik.com>
# 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.

=pod
################################## Changelog ##############################
11/05/07 21:01 v3.5
* Tweaked to resolve .cz ("expire:" along with "expires:")

09/25/07 12:27 v3.4
* Tweaked regexes to include the ".name" date syntax.

08/15/07  1:06 v3.3
* Added a bit more CLI error checking (trips off on '-d foo.com', etc.)

08/14/07 23:03 v3.2
* Polished the regexen based on Rick Moen's list of 270 TLDs
* Wrapped the date-calc section in an eval for cases where the date is past
	the Unix "death boundary" (18-Jan-2038)

08/08/07 23:26 v3.1
* Added another regex to parse the weird structure of 'extragalactic.net';
	modified another regex slightly to accomodate 'expire date' for 'nic.it'.

07/29/07  1:26 v3.0
* MAJOR REVISION:
	o The format of the 'domain-list' file has been changed, although the
	  old format is still valid. You can now add the name of the host for
	  'whois' to use as the second argument on the line; however, using the
	  '-s' command line argument will force all lookups to be done via the
	  specified host.
	o Fixed up a number of regexen for the 'jwhois' differences

07/28/07  0:41 - v2.2
* Added 'jwhois' as the preferred option, with a warning if it's not
	installed. Caching for 'jwhois' is disabled when '-X' is in effect;
	'-H' is no longer a hard-wired argument to 'whois' ('jwhois' doesn't
	support it), but is still appended if 'whois' is used.
* Tweaked a couple of the regexen to process new TLDs (.fi, .ly, etc.)
* Giving serious thought to modifying the format of the -F files; it would
	be nice to be able to specify the whois server for individual domains.

07/20/07  9:36 - v2.1
* Added a bunch of tracing/debugging statements to the date parser, making
	the '-X' option much more useful
* Built a 'switch-case' structure around the parser so that only one regex
	would apply to any given host
* Added a '-H' argument to 'whois' ("elide legal disclaimer") to make
	debugging output less annoying (and maybe speed things up fractionally)
* Made the 'no expiration date found' error into a non-fatal warning (used
	to break list processing)
* Modified the output format slightly (warnings now appear on the same line
	as the domain name)
* Domains without a registrar will no longer be omitted from the mailed
	notifications

07/19/07 22:28 - v2.0
* Now parsing .ci domains as well (millions of people cheer, world peace
	can't be far away now...)

07/19/07 20:54 - v1.9
* Added a little regex-fu to accept lines that have whitespace at the end
* Added a Big Sekrit Option ('-X' - shhh, don't tell anybody!) for debugging

07/19/07 11:56 - v1.8
* Lots and lots of fixes for many different TLDs; much mangling of regexen.
	Now handles many more expiration date types than before. Most
	importantly, domains that don't list a registrar will now be displayed
	anyway; people probably know where to send their money, but not
	necessarily _when._

07/04/07 12:28 - v1.7
* Scrapped previous approach to the .org delay; the .orgs are now sorted to
	the end of the domain list and all except the first one wait 20 seconds.
* Added a cute little time ticker to the delay routine, just because. :)

07/03/07  1:27 - v1.6
* Added a rate limiter (3/minute) for .org domains

06/30/07 18:34 - v1.5
* Added a "domain not parseable; please report" warning
* Added an "Unable to read 'whois' info" warning for the 'fgets: connection
	reset by peer' error.
* All expiration warnings are now sent as one email instead of one per
	domain; ditto the expired domains notifications.
* The 'printf' for the 'SKIPPED' error was ignoring the '-q' option; fixed

06/30/07  8:19 - v1.4
* Removed dependency on File::Find; searching PATH 'manually'
* Added an 'exit 1' to the silent failure mode of 'croak'

06/30/07  7:06 - v1.3
* Improved the date-parsing regexes (the numerical months part can now only
	match '01-12' instead of 'any two digits'); this should increase the
	reliability of resolving 'dd-mm-yyyy' vs. 'mm-dd-yyyy' somewhat.
* More accurate reporting for the 'SKIPPED' error (now shows exact reason)
* Fixed the regexes that I screwed up while adding the Dotster extension
* Added a '-v' option

06/29/07 18:54 - v1.2
* Got rid of an unnecessary system dependency ('which') - 'File::Find' is a
	bit clunky, but better than depending on unknowns...
* Another date-processing regex (ISOC-IL: 'validity: 29-06-2007')

06/29/07 17:07 - v1.1
* Modified output format to include both exp. date and days remaining
* Added another date-processing regex (DOTSTER: 'Expires on: 29-Jun-07')

06/29/07 15:06 - v1.0
I'm finally willing to admit that this script is usable. :) Recent changes
include:

* Parsing routine for "2007/08/12" date format
* 'croak' notifies admin of problems encountered in silent mode
* Added a fallback email address for 'croak'
* Fixed GMT parsing routine miscalc (thanks to Rick Moen for the heads up)

For Nosy Nellies only: *Yes*, I'm aware of the various '*Whois.pm' modules
on CPAN. None of them do what I want; the one that comes closest
(Net::XWhois) hasn't been maintained since 2001 and only covers a smallish
subset of what I want. No, I'm not interested in taking it over and
maintaining it; I've got enough to do as it is.
 
###########################################################################
=cut

use strict;
use Time::Local;
$|++;

# Command-line variables
our ($d, $e, $F, $h, $q, $s, $v, $x, $X);

### FALLBACK ADDRESS FOR NOTIFICATION ############
my $address = 'root@localhost';
##################################################

my ($name) = $0 =~ /([^\/]+)$/;

my $usage =<<"+EoT+";
Usage: $name [-e=email] [-x=expir_days] [-q] [-h] <-d=domain_name|-F=domainfile>

  -d=domain        : Domain to analyze
  -e=email_address : Send a warning message by email
  -F=domain_list   : File with a list of domains, one per line
  -h               : Print this message
  -q               : Don't print to the console (REQUIRES '-e' OPTION)
  -s=whois server  : Use alternate whois server
  -v               : Display current version of this script
  -x=days          : Change default (30d) expiration interval (REQUIRES '-e' OPTION)

+EoT+

# Locate 'whois' or (preferred) 'jwhois'
my ($whois) = grep -e, map "$_/jwhois", split /:/, $ENV{PATH};
($whois) = grep -e, map "$_/whois", split /:/, $ENV{PATH} unless $whois;
die "'whois'|'jwhois' not found in path.\n" unless $whois;
if ($whois =~ m#/whois$#){
	# $q || print "You really should install 'jwhois'; it gives better results.\n";
	# Turn down the noise (minimal output option - only works with 'whois')
	$whois .= " -H";
}
else {
	# Turn off caching for 'jwhois' if the debug option is on
	$whois .= " -f" if $X;
}

# $whois = "/usr/bin/whois";

# Find a mail client (mutt or mailx)
my ($mail) = grep -e, map "$_/mutt", split /:/, $ENV{PATH};
# Switch Mutt into 'mailx' mode if found
if ($mail){
	$mail .= " -x";
}
else {
	($mail) = grep -e, map "$_/mailx", split /:/, $ENV{PATH};
}
die "No 'mailx' or 'mutt' (mail client) found in path.\n" unless $mail;

# Read the version number at the top of the changelog
if ($v){
	seek DATA, 0, 0;
	while (<DATA>){
		if (m[^\d+/\d+/\d+[^v]+v([0-9.]+)]){
			print "Version: $1\nCopyright (C) 2007 Ben Okopnik <ben\@okopnik.com>\n\n";
			exit 0;
		}
	}
}

# Email admin if '-q' is on; otherwise, just exit with the error
sub croak {
	if ($q){
		# If '-e' wasn't specified, use the fallback address
		$e ||= $address;

		# No place to send an error if this fails... :)
		open Mail, "|$mail -s 'WARNING: $name script error' $e";
		print Mail "$name [" . localtime() . "]: ", $_[0];
		close Mail;

		exit 1;
	}
	else {
		die $_[0];
	}
}

# Display the help output if requested or in case of incorrect usage
die "$usage\n" if $h;
die "\n*ERROR: '$name' requires an email address with the '-q' and the '-x' options*\n\n$usage" if ($q || $x) && ! $e;
die "\n*ERROR: '$name' requires either a domain name or a domain list as an argument*\n\n$usage" if ! $d && ! $F;
die "\n*ERROR: Please make sure you're using correct syntax (i.e., '-d=domain_name')*\n\n$usage" if (defined $d && $d =~ /^1$/) || (defined $F && $F =~ /^1$/) || (defined $s && $s =~ /^1$/);

# Set default notification interval to 30 days
if ($x){
	croak "Expiration interval must be specified in days (0-9999).\n"
		unless $x =~ /^\d{1,4}$/;
}
else {
	$x = 30;
}

# Read the domain list file
my @domains;
if ($F){
	croak "$F is not a regular file\n" unless -f $F;
	croak "Can't read $F\n" unless -r _;
	# Open the file if it exists
	open F or croak "$F: $!\n";
	while (<F>){
		# Skip blank lines; ignore comments
		next if /^\s*(?:#|$)/;
		# Strip preceding and following blanks
		s/^\s*(.*?)\s*$/$1/;

		# Separate domain and server if they exist
		my (@line) = split;
		for (@line){
			# Strip URI method and any terminal '/'s
			s#^.*://##;
			s#/$##;
		}
		push @domains, [ @line ];
	}
	close F;
}

# Having a '-F' AND a '-d' is explicitly not excluded
if ($d){
	# Strip URI method and any terminal '/'s
	$d =~ s#^.*://##;
	$d =~ s#/$##;
	push @domains, [ $d ];
}

# Set the server if it's been specified (this REPLACES any servers defined
# in the domain-list file)
if ($s){
	$_ -> [1] = $s for @domains;
}

# Sort list to push .orgs to the end; ASCIIbetical sort otherwise
@domains = sort { ($a->[0] =~ /\.org$/i) <=> ($b->[0] =~ /\.org$/i) || $a->[0] cmp $b->[0] } @domains;

# Trim strings to specified length; return '**UNKNOWN**' if undef
sub trim {
	defined $_[0] || return "**UNKNOWN**";
	substr($_[0], 0, $_[1]);
}

# Lookup list for month number->name conversion
my (%mth,%mlookup);
@mth{map sprintf("%02d", $_), 1..12} = qw/jan feb mar apr may jun jul aug sep oct nov dec/;
# Lookup list for month name->abbrev conversion
@mlookup{qw/january february march april may june july august september october november december/} =
	(qw/jan feb mar apr may jun jul aug sep oct nov dec/) x 2;

########################## DATA COLLECTION SECTION #############################

# Process the domain list
my ($seen, %list);
for my $line (@domains){
	my ($host, $server) = @{$line};

	my $opt = $server ? "-h $server" : "";

	$q || print "\b\nProcessing $host... ";

	# Delay to avoid triggering rate limiter
	if ($host =~ /\.org$/i){
		$q || print "(NOTE: Subsequent ORG queries will be delayed by 20 seconds each due to rate limiting) "
			unless $seen;
		# Show the cute little time ticker :)
		if ($seen++){
			my @chars = split //, '|/-\\';
			for (0 .. 19){
				$q || print $chars[$_ % 4], "\b";
				sleep 1;
			}
			print " \b";
		}
	}

	# Execute the query
	my $out;
	open Who, "$whois $opt $host|" or croak "Error executing $whois: $!\n";
	{
		# Read in the entire output of 'whois' as a single string
		local $/;
		$out = <Who>;
	}
	close Who;

	# Make sure it's not DOS formatted
	$out =~ tr/\cM//d;

	# 'fgets: connection reset by peer' - bloody annoying response!
	if (!$out || $out !~ /domain/i){
		$q || print "Unable to read 'whois' info for $host. Skipping... ";
		next;
	}

	# Freak out and run away if there's no match
	if ($out =~ /no match/i){
		$q || print "No match for $host!\n";
		next;
	}
	# Ditto for bad hostnames
	if ($out =~ /No whois server is known for this kind of object/i){
		$q || print "'whois' doesn't recognize this kind of object. ";
		next;
	}

	# Convert multi-line 'labeled block' output to 'Label: value'
	my $debug;
	if ($out =~ /registrar:\n/i){
		$out =~ s/:\n(?!\n)/: /gsm;
		$debug .= "matched on line " . (__LINE__ - 1) . ": Multi-line 'labeled block'\n";
	}

	# Date preprocessing. Desired date format is '29-jun-2007'
	# 'Fri Jun 29 15:16:00 EDT 2007'
	if ($out =~ s/(date:\s*| on:\s*)[A-Z][a-z]+\s+([a-zA-Z]{3})\s+(\d+).*?(\d+)\s*$/$1$3-$2-$4/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": 'Fri Jun 29 15:16:00 EDT 2007'\n";
	}
	# '29-Jun-07'
	elsif ($out =~ s/(date:\s*| on:\s*)(\d{2})[\/ -](...)[\/ -](\d{2})\s*$/$1$2-$3-20$4/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": '29-Jun-07'\n";
	}
	# '2007-Jun-29'
	elsif ($out =~ s/[^\n]*(?:date| on|expires on\.+):\s*(\d{4})[\/-](...)[\/-](\d{2})\.?\s*$/Expiration date: $3-$2-$1/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": '2007-Jun-29'\n";
	}
	# '2007/06/29'
	elsif ($out =~ s/(?:renewal-|expir(?:e|es|y|ation)\s*)(?:date|on)?[ \t.:]*\s*(\d{4})(?:[\/-]|\. )(0[1-9]|1[0-2])(?:[\/-]|\. )(\d{2})(?:\.?\s*[0-9:.]*\s*\w*\s*|\s+\([-A-Z]+\)?)$/Expiration date: $3-$mth{$2}-$1/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": '2007/06/29'\n";
	}
	# '29-06-2007'
	elsif ($out =~ s/(?:validity:|expir(?:y|ation) date:|expire:|expires? (?:on:?|on \([dmy\/]+\):|at:))\s*(\d{2})[\/.-](0[1-9]|1[0-2])[\/.-](\d{4})\s*[0-9:.]*\s*\w*\s*$/Expiration date: $1-$mth{$2}-$3/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": '29-06-2007'\n";
	}
	# '[Expires on]     2007-06-29' (.jp, .ru)
	elsif ($out =~ s/(?:valid-date|expiration date:|paid-till:|\[expires on\]|expires on ?:|expired:)\s*(\d{4})[\/.-](0[1-9]|1[0-2])[\/.-](\d{2})(?:\s*[0-9:.]*\s*\w*\s*|T[0-9:]+Z)$/Expiration date: $3-$mth{$2}-$1/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": '[Expires on]     2007-06-29' (.jp, .ru)\n";
	}
	# 'expires:     June  29 2007' (.is)
	elsif ($out =~ s/expires:\s*([A-Z][a-z]+)\s+(\d{1,2})\s+(\d{4})\s*$/"Expiration date: " . sprintf("%02d", $2) . "-" . $mlookup{"\L$1\E"} . "-$3"/igsme){
		$debug .= "matched on line " . (__LINE__ - 1) . ": 'expires:     June  29 2007' (.is)\n";
	}
	# 'renewal: 29-June-2007'
	elsif ($out =~ s/renewal:\s*(\d{1,2})[\/ -]([A-Z][a-z]+)[\/ -](\d{4})\s*$/"Expiration date: $1-" . $mlookup{"\L$2\E"} . "-$3"/igsme){
		$debug .= "matched on line " . (__LINE__ - 1) . ": 'renewal: 29-June-2007' (.ie)\n";
	}
	# 'expire:         20080315' (.cz, .ke)
	elsif ($out =~ s/expir[ey]:\s*(\d{4})(\d{2})(\d{2})\s*$/Expiration date: $3-$mth{$2}-$1/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": 'expire:         20080315' (.cz, .ke)\n";
	}
	# 'domain_datebilleduntil: 2007-06-29T00:00:00+12:00' (.nz)
	elsif ($out =~ s/domain_datebilleduntil:\s*(\d{4})[-\/](\d{2})[-\/](\d{2})T[0-9:.+-]+\s*$/Expiration date: $3-$mth{$2}-$1/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": 'domain_datebilleduntil: 2007-06-29T00:00:00+12:00' (.nz)\n";
	}
	# '29 Jun 2007 11:58:42 UTC' (.coop)
	elsif ($out =~ s/(?:expir(?:ation|y) date|expire[sd](?: on)?)[:\] ]\s*(\d{2})[\/ -](...)[\/ -](\d{4})\s*[0-9:.]*\s*\w*\s*$/Expiration date: $1-\L$2\E-$3/igsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": '29 Jun 2007 11:58:42 UTC' (.coop)\n";
	}
	# 'Record expires on 17/8/2100' (.hm, fi)
	elsif ($out =~ s/(?:expires(?: on|:))\s*(\d{2})[\/.-]([1-9]|0[1-9]|1[0-2])[\/.-](\d{4})\s*[0-9:.]*\s*\w*\s*$/"Expiration date: $1-".$mth{sprintf "%02d", $2} . "-$3"/iegsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": 'Record expires on 17/8/2100' (.hm)\n";
	}
	# 'Expires on..............: Sat, Mar 29, 2008'
	elsif ($out =~ s/expires on\.*:\s*(?:[SMTWF][uoehra][neduit]),\s+([A-Z][a-z]+)\s+(\d{1,2}),\s+(\d{4})\s*$/"Expiration date: " . sprintf("%02d", $2) . "-\L$1-$3"/iegsm){
		$debug .= "matched on line " . (__LINE__ - 1) . ": 'Expires on..............: Sat, Mar 29, 2008'\n";
	}
	else {
		$debug = "No regexes matched.\n";
	}

	# Collect the data from each query
	for (split /\n/, $out){
		# Clip pre- and post- blanks
		s/^\s*(.*?)\s*$/$1/;
		# Squash repeated tabs and spaces
		tr/ \t//s;

		# This is where it all happens - regexes to capture registrar and expiration
		$list{$host}{Registrar} ||= $1 if /(?:maintained by|registration [^:]*by|authorized agency|registrar)(?:\s*|_)(?:name|id|of record)?:\s*(.*)$/i;
		$list{$host}{Expires} ||= $1 if /(?:expires(?: on)?|expir(?:e|y|ation) date\s*|renewal(?:[- ]date)?)[:\] ]\s*(\d{2}-[a-z]{3}-\d{4})/i;
		# print "Registrar: $list{$host}{Registrar}\nExpires: $list{$host}{Expires}\n";
	}

	# Assign default message if no registrar was found
	$list{$host}{Registrar} ||= "[[[ No registrar found ]]]";
	
	$q || print "No expiration date found in 'whois' output. Please report this domain to the author!"
		unless defined $list{$host}{Expires};

	# Debug option (activated by '-X'); exits here with parsed 'whois' output
	$debug .= "Registrar: $list{$host}{Registrar}\n" if defined $list{$host}{Registrar};
	$debug .= "Expires: $list{$host}{Expires}\n" if defined $list{$host}{Expires};
	die "\n", "=" x 70, "\n$out", "=" x 70, "\n$debug", "=" x 70, "\n" if $X;
}

$q || print "\n";

########################## DATA ANALYSIS SECTION #############################

# Get current time snapshot in UTC
my $now = timegm(gmtime);

# Convert dates to UTC epoch seconds; *will* fail on 19 Jan 2038. :)
my %months;
@months{qw/jan feb mar apr may jun jul aug sep oct nov dec/} = 0..11;

# Print the header if '$q' is off and there's content in %list
$q || %list && printf "\n\n%-24s%-36s%s\n%s\n", "Host", "Registrar", "Exp.date/Days left", "=" x 78;

# Process the collected data
my (%exp, %end);
for my $k (sort keys %list){
	unless (defined $list{$k}{Expires}){
		$q || printf "%-32s%s\n", trim($k, 31), "*** SKIPPED (missing exp. date) ***";
		delete $list{$k};
		next;
	}
	my @chunks = split /-/, $list{$k}{Expires};
	my $epoch;
	eval { $epoch = timegm(0, 0, 0, $chunks[0], $months{lc $chunks[1]}, $chunks[2] - 1900) };
	if ($@ =~ /too big/){
		$q || print "**** NOTE: Date past 19-Jan-2038 - date will NOT be calculated correctly! ****\n";
		# Set date to EPOCH_MAX
		$epoch = 2147212800;
	}
	elsif ($@){
		$q || print "$@\n";
		# Set date to EPOCH_MAX
		$epoch = 2147212800;
	}
	my $diff = int(($epoch - $now) / 86400);
	$q || printf "%-24s%-36s%-12s/%5s\n", trim($k, 23), trim($list{$k}{Registrar}, 35),
		$list{$k}{Expires}, $diff;

	# Prepare alerts if domain is expired or the expiration date is <= $x days
	if ($e && ($diff <= $x)){
		if ($diff <= 0){
			$exp{$k} = -$diff;
		}
		else {
			$end{$k} = $diff;
		}
	}
}

# Report expired domains
if (%exp){
	open Mail, "|$mail -s '$name: Expired domains' $e" or croak "$mail: $!\n";
	print Mail "According to 'whois', the following domains have expired:\n\n";
	for my $x (sort { $exp{$a} <=> $exp{$b} } keys %exp){
		my $s = $exp{$x} == 1 ? "" : "s";
		print Mail "$x ($exp{$x} day$s ago)\n";
	}
	close Mail;
}

# Report domains that will expire within the '-x' period
if (%end){
	open Mail, "|$mail -s '$name: Domain expiration warning ($x day cutoff)' $e" or croak "$mail: $!\n";
	print Mail "According to 'whois', these domains will expire soon:\n\n";
	for my $d (sort { $end{$a} <=> $end{$b} } keys %end){
		my $s = $end{$d} == 1 ? "" : "s";
		print Mail "$d (in $end{$d} day$s)\n";
	}
	close Mail;
}

__END__