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