#!/usr/bin/perl
#
#    dyfi-update.pl
#    by dy.fi admins, admin at dy dot fi
#
#    A perl client for updating dy.fi hostnames automatically
#
#    Only requires perl 5.002 with Socket and strict modules,
#    HTTP and base64 code has been embedded.
#
#    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.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
#

#
# TODO list:
#	- add a timeout in the HTTP client
#	- support checking local IP address from an interface
#	  (in case a public dynamic IP is given over PPP or DHCP,
#	  and no NAT is involved, we don't need to poll checkip!)
#

#
# CHANGELOG:
#
# Wed Jan 21 16:46:30 EET 2004 - admin at dy dot fi
#	- initial version 1.0.0
#
# Fri Mar 12 12:30:03 EET 2004 - admin at dy dot fi
#	- tuned timers
#	- version 1.0.1
#
# Mon Apr 12 10:08:47 EEST 2004 - admin at dy dot fi
#	- do not write to STDERR with warn() when we encounter an error,
#	  STDERR is not writable when we're started from an init script on
#	  RH linux, maybe others. Writing there gives us an SIGPIPE, which
#	  causes us to write an error log line, which gives us an SIGPIPE,
#	  which...
#	- try to flock() the PID file so that only one copy of the client
#	  can run at a time - a lot of people accidentally put this
#	  _daemon_ in their crontab, and soon run a hundred or a thousand
#	  copies of this script, eating their bandwidth.
#	- made the pid file a mandatory parameter
#	- export the pid of this process in the user-agent string
#	  (helps spotting multiple copies of the same client on the
#	  same machine hammering the service down - a customer service FAQ)
#	- added a Makefile for installing and uninstalling
#	- added the GPL COPYING file
#	- added a README
#	- version 1.1.0
#
# Wed Nov 10 00:43:36 EET 2004 - admin at dy dot fi
#	- if 'release' is enabled in configuration file, release the
#	  hosts using a release request when shutting down (Thanks for
#	  the patch go to Asko Leivonm�ki)
#	- install K01dyfi-update shutdown SysV init links (Asko)
#	- if /var/lock/subsys exists, create/delete subsys lock files
#	  in the init script so that RH/Fedora init scripts will run
#	  the K01dyfi-update stop scripts (Asko)
#	- create /usr/local/(etc|bin) when installing, if necessary
#	- minor documentation fix (correct config file location)
#	- truncate pid file after successful locking => do not loose
#	  the pid of an older running instance if the locking fails
#	- detect and log 'abuse' replies from the service, and quit
#	  immediately (since the service is denying our requests anyway),
#	  typically caused by script being installed in a crontab and
#	  a hundred copies hammering in parallel
#	- version 1.2.0
#

#
# PLEASE - if you make modifications to this script, and redistribute the
# modified version, please send a copy to us too, so that we can incorporate
# your changes to the original script. Also, if you redistribute your version
# directly, please rename the script so that we won't get overlapping version
# numbers when we do an 'official' distribution with the same version number.
# Thank you!
#

require 5.002;
use Socket;
use strict;
use Fcntl qw(:flock);

my ($debug, $log, $pidfile, $cfgfile,
	$update_host, $update_uri, $update_port,
	$checkip_host, $checkip_uri, $checkip_port,
	$username, $password, @hosts, $do_release);

# Default settings:

# print lots of stuff?
$debug = 0;
# log to a file, or "-" for stdout?
$log = "-";
# release hosts at shutdown?
$do_release = 0;

# update server location
# use port 8180 if it works for you
# if it doesn't, try port 80 instead (it won't work if you're behind
# a transparent proxy)
$update_host = 'www.dy.fi';
$update_uri = '/nic/update';
$update_port = 8180;
# checkip server
$checkip_host = 'checkip.dy.fi';
$checkip_uri = '/';
$checkip_port = 8180;

######## That should be all you need to touch. ##############

my($me) = "dyfi-update.pl";
my($version) = "v1.2.0";
my($helpstr) = "$me $version   Usage:

$me -f <configfile>     (recommended)

  OR

$me -u <username> -p <password> -i <pidfile> [-l <logfile>]
   [-d] hostname1.dy.fi hostname2.dy.fi ...

  If no logfile is specified, log messages are printed on standard output.
Specify the -d option to produce a very verbose debugging log which
describes every action taken. 

  Example:

$me -u email\@add.ress.fi -p password
   -l /var/log/dyfi-update.log -i /var/run/dyfi-update.pid box.dy.fi &

  dyfi-update.pl does not need root privileges run. Of course you need
to be able to write to the log & pid files, and read the config file.
The pid file is a mandatory option - the file is used to make sure that
no more than one copy of the script is run accidentally.

Please remember: dyfi-update.pl is a daemon, not a cron script.

";

#
#	parse arguments
#

my $a;
while ($a = shift @ARGV) {
	if ($a eq "-u") {
		$username = shift @ARGV;
	} elsif ($a eq "-p") {
		$password = shift @ARGV;
	} elsif ($a eq "-l") {
		$log = shift @ARGV;
	} elsif ($a eq "-i") {
		$pidfile = shift @ARGV;
	} elsif ($a eq "-f") {
		$cfgfile = shift @ARGV;
	} elsif ($a eq "-d") {
		$debug = 1;
	} elsif ($a eq "-h") {
		print $helpstr;
		exit 0;
	} else {
		if ($a =~ /^-/) {
			print $helpstr;
			exit 1;
		}
		push @hosts, $a;
	}
}

if ($cfgfile) {
	read_config($cfgfile);
}

if (!$username || !$password || $#hosts < 0) {
	print $helpstr;
	exit 1;
}

if (!$pidfile) {
	print "No pid file specified - it is mandatory.\nExample: /var/run/dyfi-update.pid\n";
	print $helpstr;
	exit 1;
}

#
#	read & parse config file
#
sub read_config {
	my($f) = @_;
	my($l);
	debug("Reading config file $f ...");
	open(F, $f) || crash("Could not open $f for reading: $!");
	my($lines) = 0;
	while ($l = <F>) {
		$lines++;
		$l =~ s/#.*$//;		# remove comments
		cleanup($l);	 	# remove whitespace
		if ($l eq "") { next; }	# skip empty lines
		my($cmd, @pars) = split(/\s+/, $l);
		$cmd = lc($cmd);
		
		if ($cmd eq "user") {
			$username = @pars[0];
		} elsif ($cmd eq "password") {
			$password = @pars[0];
		} elsif ($cmd eq "pidfile") {
			$pidfile = @pars[0];
		} elsif ($cmd eq "logfile") {
			$log = @pars[0];
		} elsif ($cmd eq "hosts") {
			push @hosts, @pars;
		} elsif ($cmd eq "release") {
			if (@pars[0] =~ /(yes|true|1)/i) {
				$do_release = 1;
			} else {
				$do_release = 0;
			}
		} else {
			crash("Unknown option in $f line $lines: $cmd");
		}
	}
	close(F) || crash("Could not open $f after reading: $!");
}

#
#	signal handlers
#

sub sighandler {
	my $signame = shift;
	
	if (($signame == 'TERM') && ($do_release)) {
		info('got SIGTERM - releasing host(s) and quitting');
		release();
	} else {
		error("got SIG$signame - quitting");
	}
	
	exit;
}

sub pipehandler {
	error('got SIGPIPE');
	return;
}

#
#	Base64 encoding code from MIME::Base64
#	which is Copyright 1995-1999, 2001 Gisle Aas.
#
sub encode_base64 ($) {
	my $res = "";
	pos($_[0]) = 0;                          # ensure start at the beginning
	
	$res = join '', map( pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
	
	$res =~ tr|` -_|AA-Za-z0-9+/|;               # # help emacs
	# fix padding at the end
	my $padding = (3 - length($_[0]) % 3) % 3;
	$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
	return $res;
}

#
#	cleanup whitespace
#

sub cleanup {
	$_[0] =~ s/^\s+//;
	$_[0] =~ s/\s+$//;
	$_[0] =~ s/\s+/ /g;
}

#
#	send to socket
#

sub ssend {
	return syswrite(SOCK, $_[0], length($_[0]));
}

#
#	a simple and stupid HTTP GET client
#	included here so that we would not depend on any specific
#	module being installed.
#	TODO: add timeout support!
#

sub htget {
	my($ht_host, $ht_port, $ht_uri, $ht_user, $ht_passwd) = @_;
	
	my($basicauth) = '';
	if ($ht_user && $ht_passwd) {
		$basicauth = sprintf("Authorization: Basic %s\r\n",
			encode_base64("$ht_user:$ht_passwd"));
	}
	
	debug("HTTP GET request to $ht_host:$ht_port $ht_uri");
	my($iaddr, $paddr, $proto);
	if (!($iaddr = inet_aton($ht_host))) {
		error("Cannot resolve host address for $ht_host: $!");
		return;
	}
	if (!($paddr = sockaddr_in($ht_port, $iaddr))) {
		error("sockaddr_in() for $ht_host:$ht_port failed: $!");
		return;
	}
	if (!($proto = getprotobyname('tcp'))) {
		error("getprotobyname(tcp) failed: $!");
		return;
	}
	
	if (!socket(SOCK, PF_INET, SOCK_STREAM, $proto)) {
		error("Cannot get socket: $!");
		return;
	}
	
	if (!connect(SOCK, $paddr)) {
		error("Cannot connect to $ht_host:$ht_port: $!");
		return;
	}
	
	my($request)	= "GET $ht_uri HTTP/1.0\r\n"
			. $basicauth
			. "User-Agent: $me $version ($$)\r\n"
			. "Host: $ht_host\r\n"
			. "Pragma: no-cache\r\n"
			. "Cache-Control: no-cache\r\n"
			. "\r\n";
	
	if (!ssend($request)) {
		error("Could not send request to $ht_host:$ht_port: $!");
		return;
	}
	
	my($state) = 0;
	my($line, $data) = ("", "");
	
	my($proto, $rcode, $rtext, %headers);
	while ($line = <SOCK>) {
		if ($state == 0) {
			# waiting for HTTP response
			cleanup($line);
			my @rt;
			($proto, $rcode, @rt) = split(' ', $line);
			$rtext = join(' ', @rt);
			if ($rcode != 200) {
				error("Request failed, server replied: $rcode $rtext");
				return ($rcode, $rtext);
			}
			$state++;
		} elsif ($state eq 1) {
			# reading HTTP headers
			cleanup($line);
			if ($line =~ /^([^:]+):\s+(.*)$/) {
				$headers{lc($1)} = $2;
			}
			if ($line eq "") { $state++; }
		} elsif ($state eq 2) {
			# reading content
			$data .= $line;
		}
	}
	
	if (!close(SOCK)) {
		error("Closing socket after reading reply failed: $!");
	}
	
	debug("HTTP GET finished successfully");
	return ($rcode, $rtext, $data, %headers);
}

#
#	logging functions
#

sub write_log {
	my($s) = @_;
	my(@tf) = localtime();
	my($tstamp) = sprintf("%04d.%02d.%02d %02d:%02d:%02d",
		@tf[5]+1900, @tf[4]+1, @tf[3], @tf[2], @tf[1], @tf[0]);
	
	if ($log eq "-") {
		print "$tstamp [$$] $s\n";
	} else {
		if (!open (LOG, ">> $log")) {
			die("$me: Could not open $log for writing: $!\n");
		}
		if (!print LOG "$tstamp [$$] $s\n") {
			die("$me: Could not write to $log: $!\n");
		}
		if (!close(LOG)) {
			die("$me: Could not close $log after writing: $!\n");
		}
	}
}

sub debug {
	if ($debug) {
		write_log("[DEBUG] @_");
	}
}

sub info {
	write_log("[INFO] @_");
}

sub error {
	# if ($log ne "-") { warn("$me: @_\n"); }
	write_log("[ERROR] @_");
}

sub crash {
	error("Crashed and burned: @_");
	exit(1);
}

#
#	write pid file
#

sub writepid {
	my($f) = @_;
	open(PF, ">>$f") || crash("Could not open $f for writing pid: $!");
	my $ofh = select(PF); $| = 1; select($ofh); # autoflush
	flock(PF, LOCK_EX|LOCK_NB) || crash("Could not flock pid file (other copy already running?): $!");
	truncate(PF, 0) || crash("Could not truncate pid file: $!");
	seek(PF, 0, 0) || crash("Could not seek to beginning of pid file: $!");
	print PF "$$\n" || crash("Could not write pid to $f: $!");
}

#
#	check my current IP address
#	TODO: add support for simply getting the address of an interface
#	in case of direct public IP assignment using DHCP/PPP
#

sub checkip {
	my ($rcode, $rtext, $data, %headers) = htget($checkip_host, $checkip_port, $checkip_uri);
	
	if ($data =~ /ip\s+address:\s+(\d+\.\d+\.\d+\.\d+)/i) {
		return $1;
	} else {
		error("Current IP address check failed!");
		return;
	}
}

#
#	parse dy.fi error codes
#

sub dyfi_errorcode {
	my(%errorcodes) = (
		'abuse'		=> 'The service feels YOU are ABUSING it!',
		'badauth'	=> 'Authentication failed',
		'nohost'	=> 'No hostname given for update, or hostname not yours',
		'notfqdn'	=> 'The given hostname is not a valid FQDN',
		'badip'		=> 'The client IP address is not valid or permitted',
		'dnserr'	=> 'Update failed due to a problem at dy.fi',
		'good'		=> 'The update was processed successfully',
		'nochg'		=> 'The successful update did not cause a DNS data change'
	);
	
	my($c) = (split(' ', $_[0]))[0];
	if ($errorcodes{$c}) {
		return $errorcodes{$c};
	} else {
		return $_[0];
	}
}

#
#	make an update request to dy.fi
#

sub update {
	my $uri = $update_uri . "?hostname=" . join(',', @hosts);
	my ($rcode, $rtext, $data, %headers) = htget($update_host, $update_port, $uri, $username, $password);
	
	if ($rcode ne 200 || lc($headers{'content-type'}) !~ /^text\/plain/ || !$data) {
		error("hostname update failed!");
		if ($rcode > 0) {
			# if this was not a network failure, don't retry quickly
			return 1;
		}
		return;
	}
	
	my(@rlines) = split("\n", $data);
	my($s);
	my($n) = 0;
	foreach $s (@rlines) {
		cleanup($s);
		if ($s eq "") { next; }
		debug("response for @hosts[$n]: $s");
		if ($s eq "nochg") {
			info("Successful refresh: @hosts[$n]");
		} elsif ($s =~ /good\s+(\d+\.\d+\.\d+\.\d+)/) {
			info("Successful update: @hosts[$n] pointed to $1");
		} else {
			error("Update failed: @hosts[$n] " . dyfi_errorcode($s));
		}
		if ($s eq 'abuse') {
			crash('ABUSE detected by the service, my requests are being denied!');
		}
		$n++;
	}
	
	return 1;
}

#
#	make a release request to dy.fi
#

sub release {
	my $uri = $update_uri . "?hostname=" . join(',', @hosts) . "&offline=yes";
	my ($rcode, $rtext, $data, %headers) = htget($update_host, $update_port, $uri, $username, $password);
	
	if ($rcode ne 200 || lc($headers{'content-type'}) !~ /^text\/plain/ || !$data) {
		error("hostname release failed!");
		if ($rcode > 0) {
			# if this was not a network failure, don't retry quickly
			return 1;
		}
		return;
	}
	
	my(@rlines) = split("\n", $data);
	my($s);
	my($n) = 0;
	foreach $s (@rlines) {
		cleanup($s);
		if ($s eq "") { next; }
		debug("response for @hosts[$n]: $s");
		if ($s eq "good") {
			info("Successful release: @hosts[$n]");
		} else {
			error("Release failed: @hosts[$n] " . dyfi_errorcode($s));
		}
		$n++;
	}
	
	return 1;
}

#
#	main #####
#

writepid($pidfile);

info("$me $version started up");

# catch signals
$SIG{'INT'} = $SIG{'QUIT'} = $SIG{'HUP'} = $SIG{'TERM'} = 'sighandler';
$SIG{'PIPE'} = 'pipehandler';

#### Please do not tune these significantly. #####
# Do an update when minimum_refresh seconds have passed even though IP
# address has not changed. dy.fi deletes old entries in 7 days, so
# refreshing every 23 hours should be often enough. We add a random
# component of up to 10 minutes to distribute dy.fi's load over time.
#
my($minimum_refresh) = 23 * 60 * 60;
my($minimum_refresh_rand) = 10 * 60;
#
# check ip address every check_interval + a random component of
# up to check_interval rand. 4 to 6 minutes should be often enouh.
my($check_interval) = 4*60;
my($check_interval_rand) = 2*60;

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

# time of next refresh
my($next_refresh) = 0;
# current address
my($current_ip);

while (1) {
	my $now = time();
	debug("--- getting current ip address ---");
	my $ip;
	$ip = checkip();
	if (!$ip) {
		# IP check failed
	} elsif ($ip eq $current_ip) {
		debug("current address is $ip, not changed from last check");
		if ($now >= $next_refresh) {
			debug("minimum refresh interval met -> updating anyway");
			if (update()) {
				$next_refresh = sprintf("%d", $now + $minimum_refresh + rand($minimum_refresh_rand));
			}
		}
	} else {
		debug("current address is $ip, changed -> updating");
		$current_ip = $ip;
		if (update()) {
			$next_refresh = sprintf("%d", $now + $minimum_refresh + rand($minimum_refresh_rand));
		}
	}
	
	my $sleeptime = sprintf("%d", $check_interval + rand($check_interval_rand));
	debug("sleeping for $sleeptime seconds...");
	sleep($sleeptime);
}