scripts / DynDNS

#!/usr/bin/perl

#
# dyndns.pl - CGI-BIN script to handle Dynamic DNS updates through http
#
# Version 1.1, latest version, documentation and bugtracker available at:
#		https://gitlab.lindenaar.net/scripts/dyndns
#
# Copyright (c) 2013 - 2019 Frederik Lindenaar
#
# This script is free software: you can redistribute and/or modify it under the
# terms of version 3 of the GNU General Public License as published by the Free
# Software Foundation, or (at your option) any later version of the license.
#
# This script 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, visit <http://www.gnu.org/licenses/> to download it.
#

use strict;
use CGI;
use POSIX;
use Net::DNS;
use feature 'state';

my $ConfigFile = 'optional';    # hardcoded, either optional, required or ignore

##############################
# Configuration section (defaults, can be set in config file)
my $DNSServer = '192.168.1.1';	# DNS Server to communicate with (use IP!)
my $ExpandCNAMEs = 1;		# CNAME levels to expand (0 to disable)
my $AllowDebugKey = 'off';	# Debuging, 'off' to disable, '' for always on
				# and other values to enable with debug= param.
my $AuthMode = 'remote';	# either 'static', 'remote' or 'both'
my $StaticSigner = '';		# required for AuthMode 'static' or 'both'
my $StaticKey = '';		# required for AuthMode 'static' or 'both'
my $RequireRR = '';		# Require existing record of this type for upd.
my $ExpireAfter = '1w';		# Expire time for registrations in minutes,
				# hours, weeks or seconds. format: [0-9]+[mhws]?
my @ReplaceRR = ('A', 'AAAA', 'TXT');	# Records types to replace in update
my $RecordTTL = '1h';           # TTL for created records, format: [0-9]+[mhws]?
my $UpdateTXT = 'Last DynDNS update on'; # if set add TXT with this+date on update
my $DeleteTXT = 'DynDNS cleared on'; # if set add TXT with this+date on delete


##############################
# Support functions
my %months = (Jan=> 0, Feb=> 1, Mar=> 2, Apr=> 3, May=>4, Jun=> 5, Jul=> 6,
                Aug=> 7, Sep=> 8, Sep=> 8, Oct=> 9, Nov=> 10, Dec=> 11);
# Parse the date and return time for:    Sun May 26 21:22:15 2013
sub parse_localtime($) {
  my ($day, $month, $mday, $time, $year)=split(' ', $_[0]);
  return mktime(reverse(split(':',$time)),$mday,$months{$month},$year-1900);
}

sub is_ipv4 { return $_[0]=~/^((25[0-5]|(2[0-4]|[01]?[0-9]?)[0-9])(\.|$)){4}/; }
sub is_ipv6 { return $_[0]=~/^([0-9a-fA-F]{0,4}(:|$)){3,8}/i; }

sub periodSeconds($) {
  my ($number, $units) = ($_[0]=~/^(\d+)([smhdw])?$/);
  if($number && $units && $units cmp 's') {
      $number *= ($units eq 'm') ? 60		# Seconds per minute
		: ($units cmp 'h') ? 3600	# Seconds per hour
		: ($units cmp 'd') ? 86400	# Seconds per day
		: 604800;			# Seconds per week
  }
  return $number;
}

# Provide a resolver object for further use, re-using the initially created one
sub getResolver() {
    state $resolver;
    unless($resolver) {
        $resolver = Net::DNS::Resolver->new(
		nameservers => [ $DNSServer ],
		recurse => 0,
        );
    }
    return $resolver;
}

my %DNS_label = (
	A	=> 'IPv4 Address',
	AAAA	=> 'IPv6 Address',
	CNAME	=> 'Alias',
	TXT	=> 'Additional Information',
	MX	=> 'Mail Server',
	NS	=> 'Name Server',
	HINFO	=> 'Host Information',
);
sub DNS_decode_rr($) {
    my ($rr) = @_;
    return $rr->address if($rr->type eq 'A');
    return $rr->address if($rr->type eq 'AAAA');
    return lc($rr->cname) if($rr->type eq 'CNAME');
    return $rr->txtdata if($rr->type eq 'TXT');
    return $rr->nsdname if($rr->type eq 'NS');
    return $rr->exchange.' (priority '.$rr->preference.')' if($rr->type eq 'MX');
    return $rr->cpu.', '.$rr->os if($rr->type eq 'HINFO');
    die "No support for $rr " . $rr->type . " in DNS_decode_rr()!, aborted!";
}

# Retrieve a single value from the DNS server of a given type or everything
sub DNS_get($;$) {
    my ($host, $type) = @_;
    if (my $response = getResolver()->send($host, $type || 'ANY')) {
	return $response unless($type);
	foreach my $rr ($response->answer) {
	    next unless $rr->type eq $type;
	    return DNS_decode_rr($rr);
	}
    } else {
	die 'DNS query failed: ', getResolver()->errorstring, "\n";
    }
}

##############################
# Initialize CGI, determine whether debugging is on and declaire fail method
my $cgi = CGI->new;
my $debug = ($AllowDebugKey cmp 'off') && (($AllowDebugKey eq '') || ($AllowDebugKey eq $cgi->param('debug')) );
my $SE = 'System Error';
my $CE = 'Configuration Error';
my $PE = 'Required parameter missing';
sub fail($$;$) {
  my ($errormsg, $debugmsg, $exitcode) = @_;
  print $debug . "\n";
  print $cgi->header(-status=>$exitcode || 503, -type=>'text/plain'),
        "ERROR - $errormsg" . ($debug ? ": $debugmsg\n" : "\n");
  exit 0;
}


# Check whether the hostname provided is actually a CNAME, returns the host
# it points to in case of a CNAME or the original hostname if it is not.
sub expand_CNAME($) {
    my ($host) = @_;
    my @found;
    while(my $cname = DNS_get($host, 'CNAME')) {
        push(@found, $host);
        $host = $cname;
        fail("DNS CNAME Not supported", "$found[0] points to a CNAME but this is not supported", 400)
                unless($ExpandCNAMEs);
        fail("DNS CNAME Chain Error", "$found[0] has > $ExpandCNAMEs level deep CNAME chain", 400)
			unless($#found < $ExpandCNAMEs);
        foreach my $r (@found) {
    	    fail("DNS CNAME Loop", "found CNAME loop for $found[0]", 400) if($cname eq $r);
        }
    }
    return $host;
}

# Get signer and key CGI paramseters, abort with HTTP 400 error if not present
sub get_authinfo($$) {
  my ($cgi, $host) = @_;

  # Get signer and key parameters
  my $signer   = ($AuthMode eq 'static') ? $StaticSigner : ($cgi->param('user')
		 || (($AuthMode eq 'both') ? $StaticSigner : $host));
  my $key      = ($AuthMode eq 'static') ? $StaticKey : ($cgi->param('secret')
		 || (($AuthMode eq 'both') ? $StaticSigner : undef));

  # Ensure we have a value for signer and key, otherwise abort the processing
  fail($PE, "No/incomplete authentication information provided", 400)
      if($signer eq '' or $key eq '');

  # and return the values
  return($signer, $key);
}

# Perform an DNS Update for a single host
sub DNS_Update($$$$$$$) {
  my ($dnsdomain, $dnshost, $ipv4, $ipv6, $signer, $key, $debug) = @_;
  my $dnsupdate = Net::DNS::Update->new($dnsdomain);
  my $ttl = periodSeconds($RecordTTL);

  # If $RequireRR is set, ensure an records of specified type exist for the name
  $dnsupdate->push(pre => yxrrset("$dnshost. $RequireRR")) if($RequireRR);

  # Replace any existing A, AAAA and TXT entries (update was requested)
  foreach my $rrtype (@ReplaceRR) {
    $dnsupdate->push(update=>rr_del("$dnshost. $rrtype"));
  }

  # Add new A and AAAA record based on whether ipv4 and ipv6 address provided
  $dnsupdate->push(update=>rr_add("$dnshost. $ttl A $ipv4")) if($ipv4);
  $dnsupdate->push(update=>rr_add("$dnshost. $ttl AAAA $ipv6")) if($ipv6);

  # Add a TXT record with the timestamp of the last update, if required
  if (my $txt = ($ipv4 or $ipv6) ? $UpdateTXT : $DeleteTXT) {
      my $timestamp = localtime();
      $dnsupdate->push(update=>rr_add("$dnshost. $ttl TXT \"$txt $timestamp\""));
  }

  # Sign the request with the signer and key
  $dnsupdate->sign_tsig($signer, $key);

  my $debugmessage = ($debug)
	? "\n\n\n========================================================\n" .
		$dnsupdate->string . "\n"
	: "\n";

  if(my $response = getResolver()->send($dnsupdate)) {
    $debugmessage .= $response->string . "\n"	if($debug);

    if ($response->header->rcode eq 'NOERROR') {
	return (200, "OK - DNS update for $dnshost succeeded: " .
		$response->header->rcode . $debugmessage);
    } else {
	# REFUSED, FORMERR
	return (403, "ERROR - DNS update for $dnshost failed: " .
		$response->header->rcode . $debugmessage);
    }
  } else {
    return (503, 'ERROR - DNS update for $dnshost failed: '.
			getResolver()->errorstring. $debugmessage);
  }
}


##############################
# Handlers for the different requests
sub handle_update($$$$$) {
  my ($mode, $host, $dnshost, $dnsdomain, $debug) = @_;
  my ($signer, $key) = get_authinfo($cgi, $host);

  # perform the action
  my ($statuscode, $statusmessage);
  if($mode eq 'delete') {
    ($statuscode, $statusmessage) =
	DNS_Update($dnsdomain, $dnshost, undef, undef, $signer, $key, $debug)
  } else {
    # Get ipv4, and ipv6 parameters
    my $remote_addr = $cgi->remote_addr;
    my $ipv4addr = $cgi->param('ipv4addr') || $cgi->param('ip');
    if ($ipv4addr == 'auto') {
        $ipv4addr = is_ipv4($remote_addr) ? $remote_addr : undef;
    }
    my $ipv6addr = $cgi->param('ipv6addr') || $cgi->param('ipv6');
    if ($ipv6addr == 'auto') {
        $ipv6addr = is_ipv6($remote_addr) ? $remote_addr : undef;
    }
    ($statuscode, $statusmessage) =
	DNS_Update($dnsdomain, $dnshost, $ipv4addr, $ipv6addr, $signer, $key, $debug);
  }

  # And report back the status
  print $cgi->header(-status=>$statuscode, -type=>'text/plain'), $statusmessage;

}

sub handle_expire($$$$$) {
  my ($mode, $host, $dnshost, $dnsdomain, $debug) = @_;
  my ($signer, $key) = get_authinfo($cgi, $host);

  my $debugmsg = ($debug) ? "\n" : '';

  # perform the action
  if(my $period = periodSeconds($ExpireAfter)) {
    my $validafter = time - $period;
    if($debug) {
      $debugmsg .= "ExpireAfter $ExpireAfter, expiring all entries older than ";
      $debugmsg .= localtime($validafter) . "\n";
    }
    foreach my $rr (getResolver->axfr($dnsdomain)) {
      next if($rr->name eq $dnsdomain);
      if($rr->type eq 'TXT' &&
		$rr->txtdata=~/$UpdateTXT(.*\d\d:\d\d:\d\d \d{4})$/){
	if(my $lastupdate = parse_localtime($1)) {
	  DNS_Update($dnsdomain, $dnshost, undef, undef, $signer, $key, $debug)
		unless($lastupdate > $validafter);
	  if($debug) {
	    $debugmsg .= ($lastupdate > $validafter) ? 'Keeping ' : 'Expiring ';
	    $debugmsg .= $rr->name . " last update ($1)\n";
	  }
	} elsif($debug) {
	  $debugmsg .= 'Skipping '. $rr->name ." TXT: '". $rr->txtdata ."'\n";
	}
      }
    }
  # And report back the status
  print $cgi->header(-status=>200, -type=>'text/plain'),
	"OK - DNS expiry for $dnsdomain succeeded\n" . $debugmsg;
  }
}

sub handle_view($$$$$) {
  my ($mode, $host, $dnshost, $dnsdomain, $debug) = @_;
  my $title = "DynDNS Updater - $host";
  print $cgi->header(-status=>200),
	$cgi->start_html(-title => $title),
	$cgi->h1($title);

  print $cgi->p("$host resolves to $dnshost")	if($host cmp $dnshost);

  print $cgi->p("Current DNS information for $dnshost:"),
	$cgi->start_table,
	$cgi->Tr({-align=>'LEFT',-valign=>'TOP'}, [
		$cgi->th(['Field', 'Value'])
	]);
  foreach my $rr (DNS_get($dnshost)->answer) {
    if(my $label = $DNS_label{$rr->type}) {
        print $cgi->Tr([ $cgi->td([$label, DNS_decode_rr($rr)]) ]);
    }
  }
  print $cgi->end_table();

  print $cgi->end_html();
}

sub handle_list($$$$$) {
  my ($mode, $host, $dnshost, $dnsdomain, $debug) = @_;
  my $title = "DynDNS Updater - $dnsdomain";

  print $cgi->header(-status=>200),
	$cgi->start_html(-title => $title),
	$cgi->h1($title);

  print $cgi->p("Current DNS information for $dnsdomain:"),
	$cgi->start_table,
	$cgi->Tr({-align=>'LEFT',-valign=>'TOP'}, [
		$cgi->th(['Name', 'Field', 'Value'])
	]);
  my $lastname = '';
  foreach my $rr (getResolver->axfr($dnsdomain)) {
    next if($rr->name eq $dnsdomain);
    if(my $label = $DNS_label{$rr->type}) {
        print $cgi->Tr([ $cgi->td([ ($lastname cmp $rr->name) ? $rr->name : '',
						$label, DNS_decode_rr($rr)]) ]);
        $lastname = $rr->name;
    }
  }
  print $cgi->end_table();

  print $cgi->end_html();
}


##############################
# Load configuration, if desired
if ($ConfigFile cmp 'ignore') {
    my $CFGFile = $0;
    $CFGFile =~ s/(\.pl)?$/.cfg/;
    if (open (CONFIG, $CFGFile)) {
        my %CONFIG = (
            allow_debug_key => \$AllowDebugKey, dns_server      => \$DNSServer,
            expand_cnames   => \$ExpandCNAMEs,  auth_mode       => \$AuthMode,
            static_signer   => \$StaticSigner,  static_key      => \$StaticKey,
            require_rr      => \$RequireRR,     replace_rr      => \@ReplaceRR,
            update_txt      => \$UpdateTXT,     delete_txt      => \$DeleteTXT,
            expire_after    => \$ExpireAfter,   record_ttl      => \$RecordTTL,
        );

        while (<CONFIG>) {
            chomp; s/^\s+//; s/\s*(#.*)?$//;        # trim whitespace & comments
            next unless length;                               # skip empty lines
            my ($key, $value) = split(/\s*=\s*/, $_, 2);   # split key and value
            my $dst = $CONFIG{$key};                 # get destination for value
            if (ref $dst eq 'SCALAR') { $$dst = $value; }   # store scalar value
            elsif (ref $dst eq 'CODE') { &$dst($value); } # call setter function
            elsif (ref $dst cmp 'ARRAY') { fail($SE, "Invalid config: $key"); }
            else { @$dst = split(/\s*,\s*/, $value); }  # split and store array
        }
        close CONFIG;
    } elsif ($ConfigFile eq 'required') {
       fail($SE, "unable to load configuration from $CFGFile: $!");
    }
}


##############################
# Validate Configuration
fail($CE, "ConfigFile must be optional, required or ignore, not '$ConfigFile'")
	unless $ConfigFile=~/optional|required|ignore/;
fail($CE, "AuthMode '$AuthMode' is unsupported must be remote, static or both")
	unless $AuthMode=~/remote|static|both/;
fail($CE, "StaticSigner must be set for \$AuthMode '$AuthMode'")
	unless ($StaticSigner or $AuthMode eq 'remote');
fail($CE, "StaticKey must be set for \$AuthMode '$AuthMode'")
	unless ($StaticKey or $AuthMode eq 'remote');
fail($CE, "RequireRR is set to unsupported type '$RequireRR'")
	if ($RequireRR and not $DNS_label{$RequireRR});
fail($CE, "RecordTTL '$RecordTTL' is not supported")
	unless ($RecordTTL=~/^\d+[smhw]?$/);
fail($CE, "ExpireAfter '$ExpireAfter' is not supported")
	unless ($ExpireAfter=~/^\d+[smhw]?$/);
fail($CE, "UpdateTXT must be set when \$ExpireAfter is set")
	if($ExpireAfter and not $UpdateTXT);
foreach my $rrtype (@ReplaceRR) {
    fail($CE, "ReplaceRR contains unsupported type '$rrtype'")
	unless exists $DNS_label{$rrtype};
}


##############################
# Determine what to do and fetch the input parameters
my $mode = $cgi->path_info || $cgi->param('mode') || 'view';
$mode=~s/^\/([^\/]+)(\/(.*))?/$1/;
my $host = $cgi->param('host') || $3;


##############################
# Dispatch the request to the correct handler
my %handlers = (
  view		=> \&handle_view,
  update	=> \&handle_update,
  delete	=> \&handle_update,
  list		=> \&handle_list,
  expire	=> \&handle_expire,
);
if($host eq '' and $mode cmp 'list' and $mode cmp 'expire') {
  fail($PE, "No host name to act on specified", 400);
} elsif(my $handler = $handlers{$mode}) {
  # Replace provided host with that of a CNAME it points to and determine domain
  my $dnshost = ($host) ? expand_CNAME($host) : undef;
  my $dnsdomain = $cgi->param('domain') || ($dnshost=~/\.(.*)$/)[0];
  $handler->($mode, $host, $dnshost, $dnsdomain, $debug);
} else {
  fail("File Not Found", "Invalid Mode '$mode' specified", 404);
}