package Martnet::DDNS;

use strict;
use warnings;
use File::Temp qw/tempfile/;
use Memoize;
use JSON::PP qw/decode_json/;

memoize('_gethosts');

our $VERSION = '0.5';

# our $misterdns = '198.251.79.234';
our $misterdns = '5.78.68.64';
our $defaultmaster = '5.78.68.64'; # could be v4 and v6 like '198.251.79.234;2607:f1c0:86e:b66f:6b86:babb:c367:b0dc'
our $keyfile = '/etc/bind/zone-management.key';

sub new {
    my $me = shift;
    my %opts = @_;
    
    return bless {
	'keyfile' => $keyfile,
	%opts
    }, $me;
}

sub _validateTypeOrDie {
    my ($t) = @_;

    die "Invalid type"
	unless ($t =~ /^_(vhosts|pureslave|custom|dnssec)$/);
}

sub _fqdn {
    my ($dom, $type) = @_;
    $type ||= '_vhosts';

    _validateTypeOrDie($type);
    
    return $dom . "$type.private.invalid.";
}

sub _validateOrDie {
    my ($dom) = @_;

    die "No domain provided"
	unless $dom;
    die "Invalid domain name (must end in a dot)"
	unless ($dom =~ /^[a-zA-Z0-9\.\-\_]+\.$/);
}

sub _lookupOrDie {
    my ($dom, $type) = @_;

    _validateOrDie($dom);
    my $fqdn = _fqdn($dom, $type);
    
    my $answer;
    my $all = '';
    my $fh;
    open($fh, "dig +short -t txt \@${misterdns} $fqdn |")
	|| die "Can't open dig: $!";
    while (<$fh>) {
	$all .= $_;
	if ($_ =~ /^\"(.+)\"$/) {
	    $answer = $1;
	}
    }
    if ($answer) {
	# We found a record; that's all I care about.
	return 1;
    }
    else {
	die "query failed: $all\n";
    }

    # Unreached
    die "Failed to find existing DNS record for $fqdn";
}

sub __docmd {
    my ($this, $cmd) = @_;

    my ($tmpfh, $filename) = tempfile();
    close $tmpfh;
    
    my $fh;
    open($fh, "|nsupdate -k $this->{keyfile} > $filename")
	|| die "Can't open nsupdate: $!";
    
    print $fh "server localhost\nzone private.invalid.\n$cmd\nshow\nsend\n";
    close $fh;

    open($fh, $filename) || die "Can't re-open tmpfile $filename: $!";
    while (<$fh>) {
	print;
    }
    close $fh;

    unlink $filename;
}

sub _txt_from_line {
    my ($line) = @_;

    # TXT in dig AXFR output may be one or more quoted segments.
    # Collect all segments and concatenate.
    my @parts;
    while ($line =~ /\"((?:\\.|[^\"])*)\"/g) {
        push @parts, $1;
    }
    my $txt = join('', @parts);

    # Unescape common presentation escapes (at minimum \" and \\).
    $txt =~ s/\\\"/\"/g;
    $txt =~ s/\\\\/\\/g;

    return $txt;
}

sub _normalize_master_value {
    my ($raw) = @_;
    return undef unless defined $raw;

    my $v = $raw;
    $v =~ s/^\s+|\s+$//g;
    return $v if $v eq '';

    # JSON objects/arrays are allowed as TXT payloads.
    if ($v =~ /^[\[{]/) {
        my $obj;
        eval { $obj = decode_json($v); 1 } or return $v; # fall back to raw

        # Supported shapes:
        #  - {"master": "ip"}
        #  - {"masters": "ip1;ip2"}
        #  - {"masters": ["ip1","ip2"]}
        if (ref($obj) eq 'HASH') {
            if (defined $obj->{masters}) {
                if (ref($obj->{masters}) eq 'ARRAY') {
                    my @m = map { defined($_) ? $_ : () } @{$obj->{masters}};
                    $v = join(';', @m);
                } else {
                    $v = $obj->{masters};
                }
            } elsif (defined $obj->{master}) {
                $v = $obj->{master};
            }
        } elsif (ref($obj) eq 'ARRAY') {
            my @m = map { defined($_) ? $_ : () } @$obj;
            $v = join(';', @m);
        }
    }

    # Normalize formatting for BIND masters blocks: no spaces, no trailing ';'
    $v =~ s/\s+//g;
    $v =~ s/;+$//;

    return $v;
}

sub _quote_txt_rdata {
    my ($s) = @_;
    $s = '' unless defined $s;
    $s =~ s/\\/\\\\/g;
    $s =~ s/\"/\\\"/g;
    return "\"$s\"";
}


sub _gethosts {
    my ($this, $type) = @_;

    unless (!defined($type)) {
	_validateTypeOrDie($type);
    }

    my $fh;
    open($fh, "dig -t AXFR \@${misterdns} private.invalid. |")
	|| die "Can't open dig: $!";

    my @vh;
    
    while (<$fh>) {
	if ($type) {
	    if (/^(\S+)\.$type\.private\.invalid\.\s+\d+\s+IN\s+TXT\s+/) {
		my $z = $1;
		my $m = _normalize_master_value(_txt_from_line($_));
		push (@vh, { zone   => $z,
			     type   => $type,
			     master => $m });
	    }
	} else {
	    # Querying everything
	    if (/^(\S+)\.(\S+)\.private\.invalid\.\s+\d+\s+IN\s+TXT\s+/) {
		my ($z, $t) = ($1, $2);
		my $m = _normalize_master_value(_txt_from_line($_));
		push (@vh, { zone   => $z,
			     type   => $t,
			     master => $m });
	    }
	}
    }
    
    return @vh;
}

# Find the type of domin that $dom is. If we don't find it, return
# undef.  (The domain $dom ends in a dot; the DNS info we find won't;
# hence the concat of the extra "." after the lc.)
# (Skip _dnssec records in this check.)
sub type {
    my ($this, $dom) = @_;

    _validateOrDie($dom);

    my @vh = $this->get();
    foreach my $i (@vh) {
	if (lc($i->{zone})."." eq lc($dom)) {
	    return $i->{type}
	    unless ($i->{type} eq '_dnssec');
	}
    }

    # Didn't find it.
    return undef;
}

sub add {
    my ($this, $dom, $master, $type) = @_;
    _validateOrDie($dom);
    my $fqdn = _fqdn($dom, $type);

    if (my $existingtype = $this->type($dom)) {
	die "Domain $dom already exists [of type $existingtype]"
	    unless ($existingtype eq '_dnssec' ||
		    $type eq '_dnssec');
    }
    
    # TXT RDATA must be quoted for JSON (and is safe for legacy strings too).
    $this->__docmd("update add $fqdn 60 TXT " . _quote_txt_rdata($master));
    $this->cleanup();
}

sub del {
    my ($this, $dom, $type) = @_;

    _lookupOrDie($dom, $type);
    my $fqdn = _fqdn($dom, $type);

    $this->__docmd("update delete $fqdn TXT");
    $this->cleanup();
}

sub get {
    my ($this, $type) = @_;

    return $this->_gethosts($type);
}

sub cleanup {
    my ($this) = @_;
    # Merge the .jnl file in with the domain file
    system("rndc sync -clean private.invalid");
    # Rebuild and reload the master vhosts files
    system("/usr/local/bin/sync-master-vhosts");
}

sub is_dnssec {
    my ($this, $dom) = @_;
    
    $dom =~ s/^(.+)\.$/$1/; # remove trailing dot

    my @h = $this->_gethosts('_dnssec');
    foreach my $i (@h) {
	if (lc($i->{zone}) eq $dom) {
	    return 1;
	}
    }
    return 0;
}

sub default_master {
    my ($this, $type) = @_;

    # This could return different masters for different types
    return $defaultmaster;
}

1;