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