dnsmanagerv1/lib/zonefile.pm

package zonefile;
use v5.14;
use Net::DNS::RR;
use Net::DNS::ZoneFile;
use Moo;
use utf8;
use URI;
use Data::Dumper;

has zone => qw/is rw/ ;
has [ qw/zonefile/ ] => qw/ is rw required 1/;

# Simple functions to manipulate lists of Net::DNS::RR

sub rr_array_del {
    my ($zones, $rr) = @_;
    my $todel = $rr->plain;
    utf8::decode($todel);
    [grep { my $v = $_->plain; utf8::decode($v); $v ne $rr->plain } @$zones]
}

sub rr_array_add {
    my ($zone, $rr) = @_;
    my @already_present = grep { $_->plain eq $rr->plain } @$zone;
    push @$zone, $rr unless @already_present;
    $zone
}

sub rr_array_new_serial {
    my $zones = shift;

    for(@{$zones}) {
        if($_->type =~ /SOA/) {
            my $serial = $_->serial;
            $_->serial($serial + 1);
        }
    }

    $zones
}

sub rr_array_serial {
    my $zones = shift;

    for(@{$zones}) {
        if($_->type =~ /SOA/) {
            return $_->serial;
        }
    }

    die "Impossible to get the zone serial."
}

sub rr_array_dump {
    my $zone = shift;
    my $dump = '';

    #  write the SOA record first
    for(@{$zone}) {
        if($_->type =~ /SOA/i) {
            $dump .= $_->string . "\n";
        }
    }

    for(@{$zone}) {
        if($_->type !~ /SOA/i) {
            $dump .= $_->string . "\n";
        }
    }

    utf8::decode($dump);

    $dump
}


sub BUILD {
    my ($self) = @_;

    my $path = $$self{zonefile};

    # zonefile is the filename
    if($$self{zonefile} =~ "://") {
        my $fileuri = URI->new($$self{zonefile});
        $path = $fileuri->path;
    }

    my $zonefile = Net::DNS::ZoneFile->new( $path );
    my @zone = $zonefile->read;
    $$self{zone} = [ @zone ];
}

sub new_serial {
    my $self = shift;
    $$self{zone} = rr_array_new_serial $$self{zone}
}

sub dump {
    my $self = shift;
    rr_array_dump $$self{zone}
}

sub serial {
    my ($self, $rr) = @_;
    rr_array_serial $$self{zone}
}

# remove a raw line that represents the RR
sub rr_del_raw {
    my ($self, $rrline) = @_;
    utf8::decode($rrline);
    say "to delete raw : $rrline";
    my $rr = Net::DNS::RR->new($rrline);
    say "to delete reformed : " . $rr->plain;
    $self->rr_del($rr)
}

sub rr_del {
    my ($self, $rr) = @_;
    $$self{zone} = rr_array_del $$self{zone}, $rr
}

# add a raw line that represents the RR
sub rr_add_raw {
    my ($self, $rrline) = @_;
    utf8::decode($rrline);
    say "to add raw : $rrline";
    my $rr = Net::DNS::RR->new($rrline);
    say "to add reformed : " . $rr->plain;
    $self->rr_add($rr)
}

sub rr_add {
    my ($self, $rr) = @_;
    $$self{zone} = rr_array_add $$self{zone}, $rr
}

sub rr_mod {
    my ($self, $rrline_old, $rrline_new) = @_;
    $self->rr_del_raw($rrline_old);
    $self->rr_add_raw($rrline_new);
}

sub rr_search {
    my ($self, $name, $type) = @_;
    my $rrlisttmp = $self->rr_array_to_array();
    [ grep { $$_{name} eq $name && $$_{type} eq $type } @$rrlisttmp ]
}

sub search_domain {
    my ($self) = @_;
    my $rr_list = $self->rr_array_to_array();

    my $soa = [ grep { $$_{type} eq "SOA" } @$rr_list ];

    for(@$soa) {
        return $$_{name};
    }

    die "No SOA in this domain.";
}

# to get all the records in relative
sub rr_array_to_array_stripped {
    my $self = shift;
    my $rr_list = $self->rr_array_to_array();

    my $domain = $self->search_domain();

    for (@$rr_list) {
        $$_{name} =~ s/\.?$domain$//;
        $$_{name} = "@" if($$_{name} =~ /^$/);

        if($$_{type} =~ /^(CNAME|SRV|MX)$/) {
            $$_{rdata} =~ s/\.?$domain$//;
            $$_{rdata} = "@" if($$_{rdata} =~ /^$/);
        }
    }

    $rr_list;
}

sub rr_array_to_array {
    my ($self) = shift;
    my $rr_list;

    for(@{$$self{zone}}) {

        my @list = split / /, $_->plain;

        my $rr;
        $$rr{name} = $list[0];
        $$rr{ttl} = $list[1];
        $$rr{class} = $list[2];
        $$rr{type} = $list[3];

        utf8::decode($$rr{name});
        utf8::decode($$rr{ttl});
        utf8::decode($$rr{class});
        utf8::decode($$rr{type});

        if($list[3] =~ /SOA/) {
            $$rr{ns} = $list[4];
            $$rr{postmaster} = $list[5];
            $$rr{serial} = $list[6];
            $$rr{refresh} = $list[7];
            $$rr{retry} = $list[8];
            $$rr{expire} = $list[9];
            $$rr{minimum} = $list[10];

            utf8::decode($$rr{ns});
            utf8::decode($$rr{postmaster});
            utf8::decode($$rr{serial});
            utf8::decode($$rr{refresh});
            utf8::decode($$rr{retry});
            utf8::decode($$rr{expire});
            utf8::decode($$rr{minimum});
        }
        elsif($list[3] =~ /^(A(AAA)?|CNAME|NS)$/) {
            $$rr{rdata} = $list[4];
            utf8::decode($$rr{rdata});
        }
        elsif($list[3] =~ /^MX$/) {
            $$rr{priority} = $list[4];
            $$rr{rdata} = $list[5];

            utf8::decode($$rr{priority});
            utf8::decode($$rr{rdata});
        }
        elsif($list[3] =~ /^TXT$/) {
            $$rr{rdata} = $_->rdstring;
            utf8::decode($$rr{rdata});
        }
        elsif($list[3] =~ /^SRV$/) {
            # _service._proto.name.     TTL   class SRV priority weight port target.
            # _sip._tcp.example.com.    86400 IN    SRV 10       60     5060 bigbox.example.com.
            $$rr{priority} = $list[4];
            $$rr{weight} = $list[5];
            $$rr{port} = $list[6];
            $$rr{rdata} = $list[7];

            utf8::decode($$rr{priority});
            utf8::decode($$rr{weight});
            utf8::decode($$rr{port});
            utf8::decode($$rr{rdata});
        }        
        elsif($list[3] =~ /^CAA$/) {
            # domain_name 10800 IN CAA 128 issue "letsencrypt.org"
            $$rr{weight} = $list[4];
            $$rr{issue} = $list[5];
            $$rr{certificateAutority} = $list[6];            
            utf8::decode($$rr{weight});             
            utf8::decode($$rr{issue});
            utf8::decode($$rr{certificateAutority});
        }
        else {
            $$rr{rdata} = $_->rdstring;
            utf8::decode($$rr{rdata});
            say "This RR is not available : " . $_->plain;
        }

        push @$rr_list, $rr;
    }

    $rr_list
}

1;