martnet-ddns/DDNS.pm

package Martnet::DDNS;

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

memoize('_gethosts');

our $VERSION = '0.7';

# Control plane update keyfile (zone-management-key)
our $keyfile = '/etc/bind/zone-management.key';

sub new {
    my $me = shift;
    my %opts = @_;

    # 'server' is where dig/axfr queries go for reading the control plane.
    # On the hidden master, localhost is correct. On other hosts, you may
    # pass 'server' => '<master-ip>'.
    my $server = $opts{server} // 'localhost';

    return bless {
        'keyfile' => $keyfile,
        'server'  => $server,
        %opts
    }, $me;
}

sub _validateTypeOrDie {
    my ($t) = @_;
    die "Invalid type"
        unless ($t =~ /^_(vhosts|pureslave|custom|config)$/);
}

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 ($this, $dom, $type) = @_;

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

    my $answer;
    my $all = '';
    my $fh;
    open($fh, "dig +short -t txt \@$this->{server} $fqdn |")
        || die "Can't open dig: $!";
    while (<$fh>) {
        $all .= $_;
        if ($_ =~ /^\"(.+)\"$/) {
            $answer = $1;
        }
    }
    if ($answer) {
        return 1;
    } else {
        die "query failed: $all\n";
    }
}

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

    my ($tmpfh, $filename) = tempfile();
    close $tmpfh;

    my $fh;
    # Capture BOTH stdout and stderr into the temp file so errors are visible,
    # and so we can fail the caller when nsupdate fails.
    open($fh, "|nsupdate -k $this->{keyfile} > $filename 2>&1")
        || die "Can't open nsupdate: $!";

    print $fh "server localhost\nzone private.invalid.\n$cmd\nshow\nsend\n";

    # If nsupdate fails, close() will return false and $? will be non-zero.
    close($fh) or do {
        open(my $rfh, $filename) || die "Can't re-open tmpfile $filename: $!";
        my $out = do { local $/; <$rfh> };
        close $rfh;
        unlink $filename;
        die "nsupdate failed (exit=$?):\n$out\n";
    };

    # Echo nsupdate output (useful for operators/logs)
    open(my $rfh, $filename) || die "Can't re-open tmpfile $filename: $!";
    while (<$rfh>) {
        print;
    }
    close $rfh;

    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 _parse_txt_payload {
    my ($raw) = @_;
    return ('', undef) unless defined $raw;

    my $v = $raw;
    $v =~ s/^\s+|\s+$//g;

    my $payload;
    if ($v =~ /^[\[{]/) {
        my $obj;
        eval { $obj = decode_json($v); 1 } or $obj = undef;

        if (defined $obj) {
            $payload = $obj if ref($obj) eq 'HASH';

            # Normalize masters string from supported JSON shapes.
            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);
            }
        }
    }

    $v = '' unless defined $v;
    $v =~ s/\s+//g;
    $v =~ s/;+$//;

    return ($v, $payload);
}

# Produce BIND nsupdate TXT RDATA as one or more quoted strings.
# BIND limits each TXT "character-string" to 255 bytes, so we chunk.
sub _quote_txt_rdata {
    my ($s) = @_;
    $s = '' unless defined $s;

    # Escape for inclusion inside a quoted TXT character-string
    $s =~ s/\\/\\\\/g;
    $s =~ s/\"/\\\"/g;

    # Conservative chunk size to stay well under 255 bytes after escaping
    my $chunk_len = 200;
    my @chunks = ($s =~ /.{1,$chunk_len}/gs);

    # Emit as: "chunk1" "chunk2" "chunk3"
    return join(' ', map { "\"$_\"" } @chunks);
}

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

    unless (!defined($type) || $type eq '') {
        _validateTypeOrDie($type);
    }

    my $fh;
    open($fh, "dig -t AXFR \@$this->{server} 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, $payload) = _parse_txt_payload(_txt_from_line($_));
                push(@vh, { zone => $z, type => $type, master => $m, payload => $payload });
            }
        } else {
            if (/^(\S+)\.(\S+)\.private\.invalid\.\s+\d+\s+IN\s+TXT\s+/) {
                my ($z, $t) = ($1, $2);
                my ($m, $payload) = _parse_txt_payload(_txt_from_line($_));
                push(@vh, { zone => $z, type => $t, master => $m, payload => $payload });
            }
        }
    }

    return @vh;
}

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};
        }
    }
    return undef;
}

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

    if (my $existingtype = $this->type($dom)) {
        die "Domain $dom already exists [of type $existingtype]";
    }

    $this->__docmd("update add $fqdn 60 TXT " . _quote_txt_rdata($txt_payload));
    $this->cleanup();
}

sub set {
    my ($this, $dom, $txt_payload, $type) = @_;
    _validateOrDie($dom);

    # Ensure it exists (for friendly errors)
    _lookupOrDie($this, $dom, $type);
    my $fqdn = _fqdn($dom, $type);

    $this->__docmd(
        "update delete $fqdn TXT\n" .
        "update add $fqdn 60 TXT " . _quote_txt_rdata($txt_payload)
    );
    $this->cleanup();
}

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

    _lookupOrDie($this, $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) = @_;
    system("rndc sync -clean private.invalid");
    system("/usr/local/bin/sync-unified-master");
}

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

    _validateOrDie($dom);
    $dom =~ s/^(.+)\.$/$1/;

    my @vh = $this->get();
    foreach my $i (@vh) {
        next unless (lc($i->{zone}) eq lc($dom));
        my $p = $i->{payload};
        return 1 if (defined $p && ref($p) eq 'HASH' && $p->{dnssec});
        return 0;
    }
    return 0;
}

sub _default_config {
    return {
        default_master         => '5.78.68.64',
        vhost_default_web_ip   => '190.92.153.173',
        soa_mname              => 'mister-dns.martnet.com.',
        soa_rname              => 'root.martnet.com.',
        ns                     => [ 'ns1.martnet.com.', 'ns2.martnet.com.' ],
        vhost_mx               => [
            { priority => 5,  host => '@' },
            { priority => 10, host => 'mx2.martnet.com.' },
            { priority => 15, host => 'mx3.martnet.com.' },
        ],
        master_ddns_keyname    => 'master-ddns-tsig',
        master_ddns_keyfile    => '/etc/bind/master-ddns-tsig.key',
    };
}

sub get_config {
    my ($this) = @_;

    # Stored at: global._config.private.invalid.
    my @cfg = $this->get('_config');
    foreach my $r (@cfg) {
        next unless lc($r->{zone}) eq 'global';
        my $p = $r->{payload};
        if (defined $p && ref($p) eq 'HASH') {
            # Merge defaults for any missing keys
            my $d = _default_config();
            for my $k (keys %$d) {
                $p->{$k} = $d->{$k} unless exists $p->{$k};
            }
            return $p;
        }
    }
    return _default_config();
}

sub set_config {
    my ($this, $cfg_hashref) = @_;
    die "Config must be a hashref" unless (defined $cfg_hashref && ref($cfg_hashref) eq 'HASH');

    # Always store compact canonical JSON (encode_json is compact)
    my $txt = encode_json($cfg_hashref);

    my $dom  = "global.";
    my $type = "_config";

    # Upsert behavior: if record exists, set, else add.
    my $existing;
    eval { $existing = $this->type($dom); 1 };
    if ($existing) {
        $this->set($dom, $txt, $type);
    } else {
        $this->add($dom, $txt, $type);
    }
}

sub default_master {
    my ($this) = @_;
    my $cfg = $this->get_config();
    return $cfg->{default_master};
}

1;