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