1# 2# Copyright (C) 2009-2012 John Eaglesham 3# 4# Permission to use, copy, modify, and distribute this software for any 5# purpose with or without fee is hereby granted, provided that the above 6# copyright notice and this permission notice appear in all copies. 7# 8# THE SOFTWARE IS PROVIDED "AS IS" AND JOHN EAGLESHAM 9# DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL 10# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL 11# JOHN EAGLESHAM BE LIABLE FOR ANY SPECIAL, DIRECT, 12# INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING 13# FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, 14# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION 15# WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16# 17 18package dlz_perl_example; 19 20use warnings; 21use strict; 22 23use Data::Dumper; 24$Data::Dumper::Sortkeys = 1; 25 26# Constructor. Everything after the class name can be folded into a hash of 27# various options and settings. Right now only log_context and argv are 28# available. 29sub new { 30 my ( $class, %config ) = @_; 31 my $self = {}; 32 bless $self, $class; 33 34 $self->{log} = sub { 35 my ( $level, $msg ) = @_; 36 DLZ_Perl::log( $config{log_context}, $level, $msg ); 37 }; 38 39 if ( $config{argv} ) { warn "Got argv: $config{argv}\n"; } 40 41 $self->{zones} = { 42 'example.com' => { 43 '@' => [ 44 { 45 type => 'SOA', 46 ttl => 86400, 47 data => 48 'ns1.example.com. hostmaster.example.com. 12345 172800 900 1209600 3600', 49 } 50 ], 51 perlrr => [ 52 { 53 type => 'A', 54 ttl => 444, 55 data => '1.1.1.1', 56 }, 57 { 58 type => 'A', 59 ttl => 444, 60 data => '1.1.1.2', 61 } 62 ], 63 perltime => [ 64 { 65 code => sub { 66 return ['TXT', '1', time()]; 67 }, 68 }, 69 ], 70 sourceip => [ 71 { 72 code => sub { 73 my ( $opaque ) = @_; 74 # Passing anything other than the proper opaque value, 75 # 0, or undef to this function will cause a crash (at 76 # best!). 77 my ( $addr, $port ) = 78 DLZ_Perl::clientinfo::sourceip( $opaque ); 79 if ( !$addr ) { $addr = $port = 'unknown'; } 80 return ['TXT', '1', $addr], ['TXT', '1', $port]; 81 }, 82 }, 83 ], 84 }, 85 }; 86 87 $self->{log}->( 88 DLZ_Perl::LOG_INFO(), 89 'DLZ Perl Script: Called init. Loaded zone data: ' 90 . Dumper( $self->{zones} ) 91 ); 92 return $self; 93} 94 95# Do we have data for this zone? Expects a simple true or false return value. 96sub findzone { 97 my ( $self, $zone ) = @_; 98 $self->{log}->( 99 DLZ_Perl::LOG_INFO(), 100 "DLZ Perl Script: Called findzone, looking for zone $zone" 101 ); 102 103 return exists $self->{zones}->{$zone}; 104} 105 106# Return the data for a given record in a given zone. The final parameter is 107# an opaque value that can be passed to DLZ_Perl::clientinfo::sourceip to 108# retrieve the client source IP and port. Expected return value is an array 109# of array refs, with each array ref representing one record and containing 110# the type, ttl, and data in that order. Data is as it appears in a zone file. 111sub lookup { 112 my ( $self, $name, $zone, $client_info ) = @_; 113 $self->{log}->( 114 DLZ_Perl::LOG_INFO(), 115 "DLZ Perl Script: Called lookup, looking for record $name in zone $zone" 116 ); 117 return unless $self->{zones}->{$zone}->{$name}; 118 119 my @results; 120 foreach my $rr ( @{ $self->{zones}->{$zone}->{$name} } ) { 121 if ( $rr->{'code'} ) { 122 my @r = $rr->{'code'}->( $client_info ); 123 if ( @r ) { 124 push @results, @r; 125 } 126 } else { 127 push @results, [$rr->{'type'}, $rr->{'ttl'}, $rr->{'data'}]; 128 } 129 } 130 131 return @results; 132} 133 134# Will we allow zone transfer for this client? Expects a simple true or false 135# return value. 136sub allowzonexfr { 137 my ( $self, $zone, $client ) = @_; 138 $self->{log}->( 139 DLZ_Perl::LOG_INFO(), 140 "DLZ Perl Script: Called allowzonexfr, looking for zone $zone for " . 141 "client $client" 142 ); 143 if ( $client eq '127.0.0.1' ) { return 1; } 144 return 0; 145} 146 147# Note the return AoA for this method differs from lookup in that it must 148# return the name of the record as well as the other data. 149sub allnodes { 150 my ( $self, $zone ) = @_; 151 my @results; 152 $self->{log}->( 153 DLZ_Perl::LOG_INFO(), 154 "DLZ Perl Script: Called allnodes, looking for zone $zone" 155 ); 156 157 foreach my $name ( keys %{ $self->{zones}->{$zone} } ) { 158 foreach my $rr ( @{ $self->{zones}->{$zone}->{$name} } ) { 159 if ( $rr->{'code'} ) { 160 my @r = $rr->{'code'}->(); 161 # The code returns an array of array refs without the name. 162 # This makes things easy for lookup but hard here. We must 163 # iterate over each array ref and inject the name into it. 164 foreach my $a ( @r ) { 165 unshift @{$a}, $name; 166 } 167 push @results, @r; 168 } else { 169 push @results, 170 [$name, $rr->{'type'}, $rr->{'ttl'}, $rr->{'data'}]; 171 } 172 } 173 } 174 return @results; 175} 176 1771; 178