#!/usr/local/bin/perl
# Copyright (C) 2014 Sergey Poznyakoff <gray@gnu.org>
#
# 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 3, 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.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use strict;
use Getopt::Long qw(:config gnu_getopt no_ignore_case);
use POSIX qw(strftime time floor);
use IO::Socket;
use Mail::Send;
use Pod::Usage;
use Pod::Man;
use Time::ParseDate;
use GDBM_File;
use Socket qw(:DEFAULT :crlf);

my $script;      # This script name;
my $descr = "notify about pending domain renews";
my $help;        # Help option requested. 
my $man;         # Man option requested.
# List of whois servers for various TLDs. Adopted from Marco d'Itri's whois.
my %whois_servers = (
    ".br.com" => "whois.centralnic.net",
    ".cn.com" => "whois.centralnic.net",
    ".de.com" => "whois.centralnic.net",
    ".eu.com" => "whois.centralnic.net",
    ".gb.com" => "whois.centralnic.net",
    ".gb.net" => "whois.centralnic.net",
    ".hu.com" => "whois.centralnic.net",
    ".no.com" => "whois.centralnic.net",
    ".qc.com" => "whois.centralnic.net",
    ".ru.com" => "whois.centralnic.net",
    ".sa.com" => "whois.centralnic.net",
    ".se.com" => "whois.centralnic.net",
    ".se.net" => "whois.centralnic.net",
    ".uk.com" => "whois.centralnic.net",
    ".uk.net" => "whois.centralnic.net",
    ".us.com" => "whois.centralnic.net",
    ".uy.com" => "whois.centralnic.net",
    ".za.com" => "whois.centralnic.net",
    ".jpn.com" => "whois.centralnic.net",
    ".web.com" => "whois.centralnic.net",
    ".za.net" => "whois.za.net",
    ".eu.org" => "whois.eu.org",
    ".za.org" => "whois.za.org",
    ".gov" => "whois.nic.gov",
    ".int" => "whois.iana.org",
    ".e164.arpa" => "whois.ripe.net",
    ".arpa" => "whois.iana.org",
    ".aero" => "whois.aero",
    ".asia" => "whois.nic.asia",
    ".biz" => "whois.nic.biz",
    ".cat" => "whois.cat",
    ".coop" => "whois.nic.coop",
    ".info" => "whois.afilias.info",
    ".jobs" => "jobswhois.verisign-grs.com",
    ".mobi" => "whois.dotmobiregistry.net",
    ".museum" => "whois.museum",
    ".name" => "whois.nic.name",
    ".pro" => "whois.registrypro.pro",
    ".tel" => "whois.nic.tel",
    ".travel" => "whois.nic.travel",
    ".ac" => "whois.nic.ac",
    ".ae" => "whois.aeda.net.ae",
    ".af" => "whois.nic.af",
    ".ag" => "whois.nic.ag",
    ".ai" => "whois.ai",
    ".am" => "whois.nic.am",
    ".as" => "whois.nic.as",
    ".priv.at" => "whois.nic.priv.at",
    ".at" => "whois.nic.at",
    ".au" => "whois.ausregistry.net.au",
    ".be" => "whois.dns.be",
    ".bg" => "whois.register.bg",
    ".bj" => "whois.nic.bj",
    ".bo" => "whois.nic.bo",
    ".br" => "whois.nic.br",
    ".co.ca" => "whois.co.ca",
    ".ca" => "whois.cira.ca",
    ".cc" => "whois.nic.cc",
    ".cd" => "whois.nic.cd",
    ".ch" => "whois.nic.ch",
    ".ci" => "www.nic.ci",
    ".ck" => "whois.nic.ck",
    ".cl" => "whois.nic.cl",
    ".cm" => "whois.netcom.cm",
    ".edu.cn" => "whois.edu.cn",
    ".cn" => "whois.cnnic.cn",
    ".uk.co" => "whois.uk.co",
    ".cx" => "whois.nic.cx",
    ".cz" => "whois.nic.cz",
    ".de" => "whois.denic.de",
    ".dk" => "whois.dk-hostmaster.dk",
    ".dm" => "whois.nic.dm",
    ".dz" => "whois.nic.dz",
    ".ee" => "whois.eenet.ee",
    ".eu" => "whois.eu",
    ".fi" => "whois.ficora.fi",
    ".fj" => "whois.usp.ac.fj",
    ".fo" => "whois.ripe.net",
    ".fr" => "whois.nic.fr",
    ".gd" => "whois.adamsnames.tc",
    ".gg" => "whois.gg",
    ".gl" => "whois.nic.gl",
    ".gm" => "whois.ripe.net",
    ".gp" => "whois.nic.gp",
    ".gs" => "whois.nic.gs",
    ".gy" => "whois.registry.gy",
    ".hk" => "whois.hkirc.hk",
    ".hm" => "whois.registry.hm",
    ".ht" => "whois.nic.ht",
    ".hu" => "whois.nic.hu",
    ".id" => "whois.pandi.or.id",
    ".ie" => "whois.domainregistry.ie",
    ".il" => "whois.isoc.org.il",
    ".im" => "whois.nic.im",
    ".in" => "whois.registry.in",
    ".io" => "whois.nic.io",
    ".ir" => "whois.nic.ir",
    ".is" => "whois.isnic.is",
    ".it" => "whois.nic.it",
    ".je" => "whois.je",
    ".jp" => "whois.jprs.jp",
    ".ke" => "whois.kenic.or.ke",
    ".kg" => "whois.domain.kg",
    ".ki" => "whois.nic.mu",
    ".kp" => "whois.kcce.kp",
    ".kr" => "whois.nic.or.kr",
    ".kz" => "whois.nic.kz",
    ".la" => "whois.nic.la",
    ".li" => "whois.nic.li",
    ".lt" => "whois.domreg.lt",
    ".lu" => "whois.dns.lu",
    ".lv" => "whois.nic.lv",
    ".ly" => "whois.nic.ly",
    ".ma" => "whois.iam.net.ma",
    ".mc" => "whois.ripe.net",
    ".me" => "whois.meregistry.net",
    ".mg" => "whois.nic.mg",
    ".ms" => "whois.nic.ms",
    ".mu" => "whois.nic.mu",
    ".mx" => "whois.nic.mx",
    ".my" => "whois.domainregistry.my",
    ".na" => "whois.na-nic.com.na",
    ".nc" => "whois.cctld.nc",
    ".nf" => "whois.nic.nf",
    ".ng" => "whois.register.net.ng",
    ".nl" => "whois.domain-registry.nl",
    ".no" => "whois.norid.no",
    ".nu" => "whois.nic.nu",
    ".nz" => "whois.srs.net.nz",
    ".pe" => "whois.nic.pe",
    ".co.pl" => "whois.co.pl",
    ".pl" => "whois.dns.pl",
    ".pm" => "whois.nic.fr",
    ".pr" => "whois.nic.pr",
    ".ps" => "whois.pnina.ps",
    ".pt" => "whois.dns.pt",
    ".re" => "whois.nic.fr",
    ".ro" => "whois.rotld.ro",
    ".edu.ru" => "whois.informika.ru",
    ".ru" => "whois.ripn.net",
    ".sa" => "whois.nic.net.sa",
    ".sb" => "whois.coccaregistry.net",
    ".se" => "whois.nic-se.se",
    ".sg" => "whois.nic.net.sg",
    ".sh" => "whois.nic.sh",
    ".si" => "whois.arnes.si",
    ".sk" => "whois.sk-nic.sk",
    ".sl" => "whois.nic.sl",
    ".sm" => "whois.ripe.net",
    ".sn" => "whois.nic.sn",
    ".st" => "whois.nic.st",
    ".su" => "whois.ripn.net",
    ".tc" => "whois.adamsnames.tc",
    ".tf" => "whois.nic.tf",
    ".th" => "whois.thnic.co.th",
    ".tk" => "whois.dot.tk",
    ".tl" => "whois.nic.tl",
    ".tm" => "whois.nic.tm",
    ".to" => "whois.tonic.to",
    ".tr" => "whois.nic.tr",
    ".tv" => "whois.nic.tv",
    ".tw" => "whois.twnic.net.tw",
    ".tz" => "whois.tznic.or.tz",
    ".net.ua" => "whois.net.ua",
    ".ua" => "whois.ua",
    ".ug" => "www.registry.co.ug",
    ".ac.uk" => "whois.ja.net",
    ".gov.uk" => "whois.ja.net",
    ".uk" => "whois.nic.uk",
    ".fed.us" => "whois.nic.gov",
    ".us" => "whois.nic.us",
    ".uy" => "whois.nic.org.uy",
    ".uz" => "whois.cctld.uz",
    ".va" => "whois.ripe.net",
    ".ve" => "whois.nic.ve",
    ".vg" => "whois.adamsnames.tc",
    ".wf" => "whois.nic.fr",
    ".ws" => "whois.samoanic.ws",
    ".yt" => "whois.nic.fr",
    ".ac.za" => "whois.ac.za",
    ".co.za" => "whois.coza.net.za",
    ".gov.za" => "whois.gov.za",
    ".xn--fiqs8s" => "cwhois.cnnic.cn",
    ".xn--fiqz9s" => "cwhois.cnnic.cn",
    ".xn--j6w193g" => "whois.hkirc.hk",
    ".xn--kprw13d" => "whois.twnic.net.tw",
    ".xn--kpry57d" => "whois.twnic.net.tw",
    ".xn--mgbaam7a8h" => "whois.aeda.net.ae",
    ".xn--mgberp4a5d4ar" => "whois.nic.net.sa",
    ".xn--o3cw4h" => "whois.thnic.co.th",
    ".xn--p1ai" => "whois.ripn.net",
    ".xn--wgbh1c" => "whois.dotmasr.eg",
    ".xn--ygbi2ammx" => "whois.pnina.ps",
# Default entry. This must be present.
    "" => "whois.publicinterestregistry.net"
    );
my $whois_delay  = 2;

# Cache
my $cachefilename;
my %cache;
my @notify_interval = (
    [ 7 * 24 * 3600, 3 * 3600 ],
    [ 14 * 24 * 3600, 24 * 3600 ],
    [ 31 * 24 * 3600, 2 * 24 * 3600 ],
);

# Notification
my $notify_template_file;
my $notify_address;
my $notify_subject = '$domain is due to expire';
my $notify_cc;

###
my $domain_file; # read domains from this file.
my %domains;     # list of domain names and corresponding whois servers.

### Debugging
my $debug;

my %debug_level = ( 'MAIN' => 0,
                    'DBM' => 0,
                    'WHOIS' => 0 );

sub debug {
    my $category = shift;
    my $level = shift;
    if ($debug_level{$category} >= $level) {
        print STDERR "$script: DEBUG[$category]: @_\n";
    }
}

sub read_config_file($) {
    my $config_file = shift;
    print STDERR "reading $config_file\n" if ($debug);
    open(FILE, "<", $config_file) or die("cannot open $config_file: $!");
    while (<FILE>) {
        chomp;
        s/^\s+//;
        s/\s+$//;
        s/\s+=\s+/=/;
        s/#.*//;
        next if ($_ eq "");
        unshift(@ARGV, "--$_");
    }
}

sub find_whois_server($) {
    my $domain = shift;
    while (!defined($whois_servers{$domain})) {
	$domain = "" unless ($domain =~ s/^.?[^.]+//);
    }
    return $whois_servers{$domain};
}

sub whois($$) {
    my $domain = shift;
    my $server = shift;
    my $port = 43;

    if ($server =~ /(.+):(.+)/) {
	$server = $1;
	$port = $2;
    }
    debug('WHOIS',1,"querying $domain from $server:$port");

    my $sock = new IO::Socket::INET (PeerAddr => $server,
				     PeerPort => $port,
				     Proto => 'tcp');
    my $expiration = undef;
    my @collect;
    
    unless ($sock) {
	print STDERR "$script: could not connect to $server:$port: $!\n";
	return undef;
    }

    print $sock "$domain\n";
    local $/ = LF;
    while (<$sock>) {
	s/$CR?$LF//;
	debug('WHOIS',2,"recv: $_");
	if (!defined($expiration)) {
	    push(@collect, $_);
	    if (/Expiration Date:/ || /expires:/ || /Registry Expiry Date:/) {
		my @args = split(/:/, $_, 2);
		$expiration = parsedate($args[1]);
		debug('WHOIS',1,
		      "Got expiration: $args[1], parsed as $expiration");
	    }
	}
    }
    unless (defined($expiration)) {
	print STDERR "$script: cannot determine expiration date for $domain\n";
	print STDERR "$script: $server responded:\n";
	foreach my $line (@collect) {
	    print STDERR "$script:  $line\n";
	}
	print STDERR "$script: end of response from $server:$port\n";
    }
    return $expiration;
}

sub interpret {
    my ($subject, $dict) = @_;
    $subject =~ s/\$([a-zA-Z_][a-zA-Z0-9_]*)/defined($dict->{$1}) ? $dict->{$1} : \$$1/gex;
    $subject =~ s/\$\{([a-zA-Z_][a-zA-Z0-9_]*\})/defined($dict->{$1}) ? $dict->{$1} : \$$1/gex;
    return $subject;
}

sub notify($$$) {
    my ($domain,$expiration,$timeleft) = @_;
    my $msg = new Mail::Send;
    my $tmpl;
    my $body;
    my $expstr = strftime("%c",localtime($expiration));

    debug('MAIN',1,"Sending notification about $domain to $notify_address");
    if ($notify_template_file) {
	open($tmpl, "<", $notify_template_file) or
	    die("cannot open notification template $notify_template_file: $!");
    }
    
    $timeleft = floor($timeleft / 86400);
    my $days;
    if ($timeleft == 0) {
        $days = "less than one day";
    } elsif ($timeleft == 1) {
	$days = "one day";
    } else {
	$days = "$timeleft days";
    }

    $msg->to($notify_address);
    my %dict = (
         domain => $domain,
         expiration => $expstr,
         daysleft => $timeleft,
         days => $days
    );

    $msg->subject(interpret($notify_subject, \%dict));
    $msg->add("Cc", $notify_cc) if $notify_cc;
    $msg->add("User-Agent", "renewck");

    if ($tmpl) {
        $body .= interpret($_, \%dict) while (<$tmpl>);
	close($tmpl);
    }
    my $fh = $msg->open;
    print $fh $body;
    $fh->close;
}

sub check_expiration($$) {
    my ($domain,$expiration) = @_;
    my $now = time();
    my $timeleft = $expiration - $now;
    debug('MAIN',1,"$domain expires in $timeleft seconds");
    return if ($timeleft < 0);
    foreach my $interval (@notify_interval) {
	if ($interval->[0] >= $timeleft) {
	    debug('MAIN',2,"$domain expires in less than $interval->[0] seconds; using notification interval $interval->[1]");
	    my $ts = $cache{$domain};
	    debug('DBM',1,
		  strftime("$domain: last notification on %c", localtime($ts)));
	    if ($now - $ts >= $interval->[1]) {
		notify($domain, $expiration, $timeleft);
		$cache{$domain} = $now;
		return;
	    }
	}
    }
}

##########################################

($script = $0) =~ s/.*\///;

## Read configuration
if ($ENV{'RENEWCK_CONF'}) {
    read_config_file($ENV{'RENEWCK_CONF'});
} elsif (-e "$ENV{HOME}/.renewck.conf") {
    read_config_file("$ENV{HOME}/.renewck.conf");
}

GetOptions("help|h" => \$help,
           "man" => \$man,
           "debug|d:s" => sub {
               if (!$_[1]) {
                   foreach my $key (keys %debug_level) {
                       $debug_level{$key} = 1;
                   }
               } else {
                   foreach my $cat (split(/,/, $_[1])) {
                       my @s = split(/[:=]/, $cat, 2);
                       $s[0] =~ tr/[a-z]/[A-Z]/;
                       if (defined($debug_level{$s[0]})) {
                           $debug_level{$s[0]} =
                               ($#s == 1) ? $s[1] : 1;
                       } else {
                           print STDERR "$script: no such category: $s[0]\n";
                           exit(1);
                       }
                   }
               }
           },
	   "domain|d:s" => sub {
	       foreach my $dom (split(/,/, $_[1])) {
		   my @s = split(/[=]/, $dom, 2);
#                       $s[0] =~ tr/[a-z]/[A-Z]/;
		   if ($#s == 0) {
		       $domains{$s[0]} = find_whois_server($s[0]);
		   } else {
		       $domains{$s[0]} = $s[1];
		   }
               }
           },
	   "file=s" => \$domain_file,
	   "notify-template=s" => \$notify_template_file,
	   "notify-address=s" => \$notify_address,
	   "notify_subject=s" => \$notify_subject,
	   "notify_cc=s", => \$notify_cc,
	   "whois-server=s" => sub { $whois_servers{""} = $_[1]; },
	   "whois-delay=i" => \$whois_delay,
	   "cache-file=s" => \$cachefilename
    ) or exit(1);

pod2usage(-message => "$script: $descr", -exitstatus => 0) if $help;
pod2usage(-exitstatus => 0, -verbose => 2) if $man;

$cachefilename = "$ENV{HOME}/.renewck.db" unless ($cachefilename);
unless ($notify_address) {
  if (defined($ENV{'USER'})) {
    $notify_address = $ENV{'USER'};
  } elsif (defined($ENV{'LOGNAME'})) {
    $notify_address = $ENV{'LOGNAME'};
  }
}

if ($domain_file) {
    open(FILE, "<", $domain_file)
        or die("Cannot open file $domain_file for reading");
    while (<FILE>) {
        chomp;
        s/^\s+//;
        s/\s+$//;
        s/#.*//;
        next if ($_ eq "");
	my @a = split;
	$domains{$a[0]} = $#a > 0 ? $a[1] : find_whois_server($a[1]);
    }
    close(FILE);
}

if (keys(%domains) == 0) {
    print STDERR "$script: no domain names supplied\n";
    exit(1);
}

## Open DBM storage
tie %cache, 'GDBM_File', $cachefilename, &GDBM_WRCREAT, 0640;

while (my ($domain,$server) = each(%domains)) {
    my $expire = whois($domain,$server);
    if (defined($expire)) {
	check_expiration($domain,$expire);
    }
    sleep($whois_delay);
}

__END__

=head1 renewck

renewck - notify about domains due to expire

=head1 SYNOPSIS

renewck [I<options>]

=head1 DESCRIPTION

The B<renewck> utility monitors a set of Internet domains.  For each
configured domain it queries a B<whois> server about its expiration
date.  If the domain is due to expire within a preconfigured time
interval, B<renewck> mails a notification about the fact.

The utility is intended to be started periodically as a cron job.

B<Renewck> will re-send notifications until domain is renewed or finally
expired.  The notification schedule is as follows:

For each domain domain expiring within a month from the current date, a
new notification is send each 3 days.

For domains expiring within two weeks, notifications are re-sent daily.

For domains expiring within a week, notifications are re-sent each 3 hours.    

=head1 OPTIONS

=over 4

=item B<--domain>=I<domsrv>[,I<domsrv>...]

Adds listed domains to the list of monitored domains.  Each I<domsrv>
is either a single domain name or a pair B<domain>=B<server>[:B<port>],
where B<server> stands for the name of whois server to be queried for
that domain, and optional B<port> is a decimal port number to be used
instead of the default 43.

Unless specified explicitely, the whois server to query is selected depending
on the TLD of the domain.  If no specific whois server found, the default
one will be used.  The default whois server is
F<whois.publicinterestregistry.net>, unless set otherwise by the
B<--whois-server> option.

=item B<--file>=F<FILE>

Read domain names from the F<FILE>.  The file must list a single domain
on each line.  Optionally, a B<server>[:B<port>] specification is allowed
after the domain name, separated from it by any amount of white space (see
the B<--domain> option for the description of that specification).

UNIX-like comments are allowed.  Empty lines are ignored.    

=item B<--notify-address>=I<email>

Sent notifications to I<email> instead of to the user which invoked B<renewck>.

=item B<--notify_cc>=I<emails>

A comma-separated list of addresses for the notification mail Cc: header.

=item B<--notify_subject>=I<text>

Use I<text> as the subject of notification emails.  The following
variables are expanded within the template text: 

    $domain       domain the notification refers to;
    $expiration   expiration date, in the preferred date and time
                  representation for the current locale;    
    $daysleft     number of days left to the expiration date;
    $days         number of days as a string, e.g. "two days";

The default subject line is:

    $domain is due to expire

=item B<--notify-template>=F<FILE>

The file to be used as a template for the message body.  This text
is expanded as described for B<--notify-subject> above.    

=item B<--whois-server>=I<server>[:I<port>]

Sets the default whois server (instead of the hardcoded
F<whois.publicinterestregistry.net>).  If I<port> is also supplied, it
will be used instead of the default port 43.

=item B<--whois-delay>=I<N>

Many servers (in particular F<whois.publicinterestregistry.net> used by
default), implement certain restrictions regarding maximum number of queries
an IP address can make in a unit of time.  To keep request rate within these
policies, B<renewck> introduces a 2-second delay between whois queries.
This option allows to tune that delay.    

=item B<--cache-file>=F<FILE>

Keep notification history in a GDBM database file named F<FILE>.  By default,
it is B<.renewck.db> in the user's home directory.    
    
=item B<--debug>[=I<spec>[,I<spec>...]], B<-d>[I<spec>[,I<spec>...]]

Set debugging level.  A I<spec> is either B<category> or B<category>=B<level>,
where B<category> is a debugging category name and B<level> is a decimal
verbosity level.  Valid categories are: C<MAIN>, C<DBM> and          
C<WHOIS> (all case-insensitive).  If B<level> is not supplied, 1 is used      
instead.

=item B<--help>, B<-h>

Show a terse help summary and exit.

=item B<--man>

Prints the manual page and exits.

=back

=head1 CONFIGURATION FILE

The program reads its configuration from one of the following locations:

=over 4

=item B<a.> File name given by C<RENEWCK_CONF> environment variable (if set)

=item B<b.> The file F<.renewck.conf> in the user home directory

=back

The first existing file is read.  It is an error if the B<$RENEWCK_CONF>
variable is set, but points to a file that does not exist.  It is OK
if B<$RENEWCK_CONF> is not set and F<.renewck.conf> does not exist.
It is, however, an error if any of these file exists,  but is not readable.

The configuration file has the usual UNIX configuration format.  Empty
lines and UNIX comments are ignored.  Each non-empty line is either an
option name, or option assignment, i.e. B<opt>=B<val>, with any amount of
optional whitespace around the equals sign.  Valid option names are
the same as long command line options, but without the leading B<-->.

For example:

    file  = domain.list
    notify-cc = root    
    
=head1 AUTHOR

Sergey Poznyakoff <gray@gnu.org>

=cut

	   


