File Coverage

blib/lib/Net/DNS/Create/Route53.pm
Criterion Covered Total %
statement 43 80 53.7
branch 19 40 47.5
condition 6 24 25.0
subroutine 10 15 66.6
pod 0 8 0.0
total 78 167 46.7


line stmt bran cond sub pod time code
1             # Copyright (c) 2013-2014 David Caldwell, All Rights Reserved.
2              
3             package Net::DNS::Create::Route53;
4 1     1   7 use feature ':5.10';
  1         2  
  1         180  
5 1     1   5 use strict;
  1         2  
  1         33  
6 1     1   5 use warnings;
  1         2  
  1         41  
7              
8 1     1   6 use Net::DNS::Create qw(internal full_host email interval);
  1         2  
  1         9  
9 1     1   1383 use Net::Amazon::Route53;
  1         318841  
  1         1933  
10              
11             our %config;
12             sub import {
13 1     1   3 my $package = shift;
14 1         4 my %c = @_;
15 1         7 $config{$_} = $c{$_} for keys %c;
16             }
17              
18             my $r53;
19             sub r53() {
20 0   0 0 0 0 $r53 //= Net::Amazon::Route53->new(id => $config{amazon_id},
21             key => $config{amazon_key});
22             }
23              
24             my $zones;
25             sub hosted_zone($) {
26             # The eval works around a bug in Net::Amazon::Route53 where it dies if there are no zones at all.
27 0 0 0 0 0 0 $zones = eval { [r53->get_hosted_zones()] } || [] unless defined $zones;
28 0   0     0 (grep { $_->name eq $_[0] } @$zones)[0] // undef;
  0         0  
29             }
30              
31             sub txt(@) {
32 6 100   6 0 178 map { s/[^-a-zA-Z0-9._='():;* ]/$& eq '"' ? '\\"' : sprintf("\\%03o", ord($&))/ge;
  7         24  
  29         113  
33 7         54 "\"$_\"" } @_;
34             }
35              
36             sub group_by_type_and_name($$) {
37 1     1 0 2 my ($re, $entries) = @_;
38 1         9 my %set;
39 1         4 for my $r (grep { lc($_->type) =~ $re } @$entries) {
  27         321  
40 11         325 push @{$set{$r->type .'_'. $r->name}}, $r;
  11         26  
41             }
42 1         56 map { $set{$_} } keys %set;
  7         18  
43             }
44              
45             my @domain;
46 1     1   37 sub _domain() { @domain } # Hook for testing
47             sub domain($$) {
48 1     1 0 4 my ($package, $domain, $entries) = @_;
49              
50 1         3 my @entries = map { ;
51 27         822 my $rr = lc $_->type;
52              
53 27 50 33     558 $rr eq 'soa' ? () : # Amazon manages its own SOA stuff. Just ignore things we might have.
    100 100        
    100          
    100          
    100          
54             $rr eq 'rp' ? (warn("Amazon doesn't support RP records :-(") && ()) :
55              
56             $rr eq 'mx' || $rr eq 'ns' || $rr eq 'srv' || $rr eq 'txt' ? () : # Handled specially, below
57              
58             +{
59             action => 'create',
60             name => $_->name.'.',
61             ttl => $_->ttl,
62             type => uc $rr,
63             $rr eq 'a' ? (value => $_->address) :
64             $rr eq 'cname' ? (value => $_->cname.'.') :
65             (err => warn "Don't know how to handle \"$rr\" RRs yet.")
66              
67             }
68             } @$entries;
69              
70             # Amazon wants all NS,MX,TXT and SRV entries for a particular name in one of their entries. We get them in as
71             # separate entries so first we have to group them together.
72 1         62 push @entries, map { my @set = @$_;
  7         51  
73 7         21 my $rr = lc $set[0]->type;
74 2         41 $rr eq 'ns' && $set[0]->name.'.' eq $domain ? () : # Amazon manages its own NS stuff. Just ignore things we might have.
75             +{
76             action => 'create',
77             name => $set[0]->name.'.',
78             ttl => $set[0]->ttl,
79             type => uc $rr,
80 0         0 $rr eq 'mx' ? (records => [map { $_->preference." ".$_->exchange.'.' } @set]) :
81 1         24 $rr eq 'ns' ? (records => [map { $_->nsdname.'.' } @set] ) :
82 6         99 $rr eq 'srv' ? (records => [map { $_->priority ." ".$_->weight ." ".$_->port ." ".$_->target.'.' } @set]) :
83 7 50 66     100 $rr eq 'txt' ? (records => [map { join ' ', txt($_->char_str_list) } @set]) :
    100          
    50          
    100          
    100          
84             (err => die uc($rr)." can't happen here!")
85             }
86             } group_by_type_and_name(qr/^(?:mx|ns|srv|txt)$/, $entries);
87              
88 1         314 push @domain, { name => $domain,
89             entries => \@entries };
90             }
91              
92             my $counter = rand(1000);
93             sub master() {
94 0     0 0   my ($package) = @_;
95 0           local $|=1;
96              
97 0           for my $domain (@domain) {
98 0           my $zone = hosted_zone(full_host($domain->{name}));
99 0 0 0       if (!$zone && scalar @{$domain->{entries}}) {
  0            
100 0           my $hostedzone = Net::Amazon::Route53::HostedZone->new(route53 => r53,
101             name => $domain->{name},
102             comment=>(getpwuid($<))[0].'/'.__PACKAGE__,
103             callerreference=>__PACKAGE__."-".localtime."-".($counter++));
104 0           print "New Zone: $domain->{name}...";
105 0           $hostedzone->create();
106 0           $zone = $hostedzone;
107 0           print "Created. Nameservers:\n".join('', map { " $_\n" } @{$zone->nameservers});
  0            
  0            
108             }
109              
110 0 0         if ($zone) {
111 0 0 0       my $current = [ grep { $_->type ne 'SOA' && ($_->type ne 'NS' || $_->name ne $domain->{name}) } @{$zone->resource_record_sets} ];
  0            
  0            
112 0           my $new = [ map { Net::Amazon::Route53::ResourceRecordSet->new(%{$_},
  0            
  0            
113 0   0       values => [$_->{value} // @{$_->{records}}],
114             route53 => r53,
115 0           hostedzone => $zone) } @{$domain->{entries}} ];
116 0           printf "%s: %d -> %d\n", $domain->{name}, scalar @$current, scalar @$new;
117 0 0         my $change = scalar @$current > 0 ? r53->atomic_update($current,$new) :
    0          
118             scalar @$new > 0 ? r53->batch_create($new) :
119             undef;
120              
121 0 0         unless (scalar @{$domain->{entries}}) {
  0            
122 0           print "Deleting $domain->{name}\n";
123 0           $zone->delete;
124             }
125             }
126             }
127             }
128              
129             sub domain_list($@) {
130 0     0 0   my $zone = hosted_zone(full_host($_[0]));
131 0 0         printf "%-30s %-30s %s\n", $zone ? $zone->id : '', $_[0], !$zone ? '' : ' ['.join(" ",@{$zone->nameservers}).']';
  0 0          
132             }
133              
134 0     0 0   sub master_list($$) {
135             # This doesn't really make sense in the route53 context
136             }
137              
138             1;
139             __END__