line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::DNSServer::DBMCache; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
879
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
40
|
|
4
|
1
|
|
|
1
|
|
6
|
use Exporter; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
44
|
|
5
|
1
|
|
|
1
|
|
6
|
use vars qw(@ISA $expiration_check); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
57
|
|
6
|
1
|
|
|
1
|
|
6
|
use Net::DNSServer::Base; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
21
|
|
7
|
1
|
|
|
1
|
|
4
|
use Net::DNS; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
182
|
|
8
|
1
|
|
|
1
|
|
6
|
use Net::DNS::RR; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
24
|
|
9
|
1
|
|
|
1
|
|
7
|
use Net::DNS::Packet; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
96
|
|
10
|
1
|
|
|
1
|
|
5
|
use Carp qw(croak); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
58
|
|
11
|
1
|
|
|
1
|
|
6
|
use IO::File; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
179
|
|
12
|
1
|
|
|
1
|
|
6
|
use Fcntl qw(LOCK_SH LOCK_EX LOCK_UN); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
195
|
|
13
|
1
|
|
|
1
|
|
15362
|
use Storable qw(freeze thaw); |
|
1
|
|
|
|
|
10788
|
|
|
1
|
|
|
|
|
295
|
|
14
|
1
|
|
|
1
|
|
5700
|
use GDBM_File; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
@ISA = qw(Net::DNSServer::Base); |
17
|
|
|
|
|
|
|
$expiration_check = undef; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# Created and passed to Net::DNSServer->run() |
20
|
|
|
|
|
|
|
sub new { |
21
|
|
|
|
|
|
|
my $class = shift || __PACKAGE__; |
22
|
|
|
|
|
|
|
my $self = shift || {}; |
23
|
|
|
|
|
|
|
if (! $self -> {dbm_file} ) { |
24
|
|
|
|
|
|
|
croak 'Usage> new({ |
25
|
|
|
|
|
|
|
dbm_file => "/var/named/dns_cache.db", |
26
|
|
|
|
|
|
|
fresh => 0})'; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
# Create lock file to serialize DBM accesses and avoid DBM corruption |
29
|
|
|
|
|
|
|
my $lock = IO::File->new ("$self->{dbm_file}.LOCK", "w") |
30
|
|
|
|
|
|
|
|| croak "Could not write to $self->{dbm_file}.LOCK"; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# Test to make sure it can be locked and unlocked successfully |
33
|
|
|
|
|
|
|
flock($lock,LOCK_SH) || die "Couldn't get shared lock on $self->{dbm_file}.LOCK"; |
34
|
|
|
|
|
|
|
flock($lock,LOCK_EX) || die "Couldn't get exclusive lock on $self->{dbm_file}.LOCK"; |
35
|
|
|
|
|
|
|
flock($lock,LOCK_UN) || die "Couldn't unlock on $self->{dbm_file}.LOCK"; |
36
|
|
|
|
|
|
|
$lock->close(); |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
$self -> {dns_cache} = {}; |
39
|
|
|
|
|
|
|
# Actually connect to dbm file as a test |
40
|
|
|
|
|
|
|
tie (%{ $self -> {dns_cache} }, |
41
|
|
|
|
|
|
|
'GDBM_File', |
42
|
|
|
|
|
|
|
$self->{dbm_file}, |
43
|
|
|
|
|
|
|
&GDBM_WRCREAT, |
44
|
|
|
|
|
|
|
0640) |
45
|
|
|
|
|
|
|
|| croak "Could not connect to $self->{dbm_file}"; |
46
|
|
|
|
|
|
|
if ($self -> {fresh}) { |
47
|
|
|
|
|
|
|
# Wipe any old information if it exists from last time |
48
|
|
|
|
|
|
|
%{ $self -> {dns_cache} } = (); |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
untie (%{ $self -> {dns_cache} }); |
51
|
|
|
|
|
|
|
return bless $self, $class; |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# Check if the TTL is still good |
55
|
|
|
|
|
|
|
sub validate_ttl { |
56
|
|
|
|
|
|
|
my $value = shift or return undef; |
57
|
|
|
|
|
|
|
return undef unless (ref $value) eq "ARRAY"; |
58
|
|
|
|
|
|
|
foreach my $entry (@$value) { |
59
|
|
|
|
|
|
|
# If this entry has expired, then throw the whole thing out |
60
|
|
|
|
|
|
|
return undef if (ref $entry) ne "ARRAY" || $entry->[0] < time; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
# If nothing has expired, the data is still valid |
63
|
|
|
|
|
|
|
return $value; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# Called immediately after incoming request |
67
|
|
|
|
|
|
|
# Takes the Net::DNS::Packet question as an argument |
68
|
|
|
|
|
|
|
sub pre { |
69
|
|
|
|
|
|
|
my $self = shift; |
70
|
|
|
|
|
|
|
my $net_dns_packet = shift || croak 'Usage> $obj->resolve($Net_DNS_obj)'; |
71
|
|
|
|
|
|
|
$self -> {question} = $net_dns_packet; |
72
|
|
|
|
|
|
|
$self -> {net_server} -> {usecache} = 1; |
73
|
|
|
|
|
|
|
return 1; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# Called after all pre methods have finished |
77
|
|
|
|
|
|
|
# Returns a Net::DNS::Packet object as the answer |
78
|
|
|
|
|
|
|
# or undef to pass to the next module to resolve |
79
|
|
|
|
|
|
|
sub resolve { |
80
|
|
|
|
|
|
|
my $self = shift; |
81
|
|
|
|
|
|
|
my $dns_packet = $self -> {question}; |
82
|
|
|
|
|
|
|
my ($question) = $dns_packet -> question(); |
83
|
|
|
|
|
|
|
my $key = $question->string(); |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# Create lock file to serialize DBM accesses and avoid DBM corruption |
86
|
|
|
|
|
|
|
my $lock = IO::File->new ("$self->{dbm_file}.LOCK", "w"); |
87
|
|
|
|
|
|
|
$lock && flock($lock,LOCK_SH); |
88
|
|
|
|
|
|
|
tie (%{ $self -> {dns_cache} }, |
89
|
|
|
|
|
|
|
'GDBM_File', |
90
|
|
|
|
|
|
|
$self->{dbm_file}, |
91
|
|
|
|
|
|
|
&GDBM_WRCREAT, |
92
|
|
|
|
|
|
|
0640); |
93
|
|
|
|
|
|
|
my $cache_structure = $self -> {dns_cache} -> {"$key;structure"} || undef; |
94
|
|
|
|
|
|
|
$cache_structure &&= thaw $cache_structure; |
95
|
|
|
|
|
|
|
unless ($cache_structure && |
96
|
|
|
|
|
|
|
(ref $cache_structure) eq "ARRAY" && |
97
|
|
|
|
|
|
|
(scalar @$cache_structure) == 3) { |
98
|
|
|
|
|
|
|
print STDERR "DEBUG: Cache miss on [$key;structure]\n"; |
99
|
|
|
|
|
|
|
untie (%{ $self -> {dns_cache} }) |
100
|
|
|
|
|
|
|
if tied %{ $self -> {dns_cache} }; |
101
|
|
|
|
|
|
|
return undef; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
print STDERR "DEBUG: Cache hit on [$key;structure]\n"; |
104
|
|
|
|
|
|
|
# Structure key found in cache, so lookup actual values |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
# ANSWER Section |
107
|
|
|
|
|
|
|
my $answer_ref = $self->fetch_rrs($cache_structure->[0]); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# AUTHORITY Section |
110
|
|
|
|
|
|
|
my $authority_ref = $self->fetch_rrs($cache_structure->[1]); |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# ADDITIONAL Section |
113
|
|
|
|
|
|
|
my $additional_ref = $self->fetch_rrs($cache_structure->[2]); |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
my $response = undef; |
116
|
|
|
|
|
|
|
# Make sure all sections were loaded successfully from cache. |
117
|
|
|
|
|
|
|
if ($answer_ref && $authority_ref && $additional_ref) { |
118
|
|
|
|
|
|
|
# Initialize the response packet with a copy of the request |
119
|
|
|
|
|
|
|
# packet in order to set the header and question sections |
120
|
|
|
|
|
|
|
$response = bless \%{$dns_packet}, "Net::DNS::Packet" |
121
|
|
|
|
|
|
|
|| die "Could not initialize response packet"; |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# Install the RRs into their corresponding sections |
124
|
|
|
|
|
|
|
$response->push("answer", @$answer_ref); |
125
|
|
|
|
|
|
|
$response->push("authority", @$authority_ref); |
126
|
|
|
|
|
|
|
$response->push("additional", @$additional_ref); |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
$self -> {net_server} -> {usecache} = 0; |
129
|
|
|
|
|
|
|
} else { |
130
|
|
|
|
|
|
|
# If not loaded, flush structure key to ensure |
131
|
|
|
|
|
|
|
# it will be re-stored in the post() phase. |
132
|
|
|
|
|
|
|
delete $self -> {dns_cache} -> {"$key;structure"}; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
untie (%{ $self -> {dns_cache} }) if tied %{ $self -> {dns_cache} }; |
135
|
|
|
|
|
|
|
$lock->close(); |
136
|
|
|
|
|
|
|
return $response; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
sub fetch_rrs { |
140
|
|
|
|
|
|
|
my $self = shift; |
141
|
|
|
|
|
|
|
my $array_ref = shift; |
142
|
|
|
|
|
|
|
my @rrs = (); |
143
|
|
|
|
|
|
|
if (ref $array_ref ne "ARRAY") { |
144
|
|
|
|
|
|
|
return undef; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
foreach my $rr_string (@$array_ref) { |
147
|
|
|
|
|
|
|
my $lookup = validate_ttl(thaw ($self -> {dns_cache} -> {"$rr_string;lookup"})) || undef; |
148
|
|
|
|
|
|
|
unless ($lookup && ref $lookup eq "ARRAY") { |
149
|
|
|
|
|
|
|
print STDERR "DEBUG: Lookup Cache miss on [$rr_string]\n"; |
150
|
|
|
|
|
|
|
return undef; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
print STDERR "DEBUG: Lookup Cache hit on [$rr_string]\n"; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
foreach my $entry (@$lookup) { |
155
|
|
|
|
|
|
|
return undef unless ref $entry eq "ARRAY"; |
156
|
|
|
|
|
|
|
my ($expire,$rdatastr) = @$entry; |
157
|
|
|
|
|
|
|
my $rr = Net::DNS::RR->new ("$rr_string\t$rdatastr"); |
158
|
|
|
|
|
|
|
$rr->ttl($expire - time); |
159
|
|
|
|
|
|
|
push @rrs, $rr; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
return \@rrs; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# Called after response is sent to client |
166
|
|
|
|
|
|
|
sub post { |
167
|
|
|
|
|
|
|
my $self = shift; |
168
|
|
|
|
|
|
|
if ($self -> {net_server} -> {usecache}) { |
169
|
|
|
|
|
|
|
# Create lock file to serialize DBM accesses and avoid DBM corruption |
170
|
|
|
|
|
|
|
my $lock = IO::File->new ("$self->{dbm_file}.LOCK", "w"); |
171
|
|
|
|
|
|
|
$lock && flock($lock,LOCK_EX); |
172
|
|
|
|
|
|
|
tie (%{ $self -> {dns_cache} }, |
173
|
|
|
|
|
|
|
'GDBM_File', |
174
|
|
|
|
|
|
|
$self->{dbm_file}, |
175
|
|
|
|
|
|
|
&GDBM_WRCREAT, |
176
|
|
|
|
|
|
|
0640); |
177
|
|
|
|
|
|
|
# Grab the answer packet |
178
|
|
|
|
|
|
|
my $dns_packet = shift; |
179
|
|
|
|
|
|
|
# Store the answer into the cache |
180
|
|
|
|
|
|
|
my ($question) = $dns_packet -> question(); |
181
|
|
|
|
|
|
|
my $key = $question->string(); |
182
|
|
|
|
|
|
|
my @s = (); |
183
|
|
|
|
|
|
|
push @s, $self->store_rrs($dns_packet->answer); |
184
|
|
|
|
|
|
|
push @s, $self->store_rrs($dns_packet->authority); |
185
|
|
|
|
|
|
|
push @s, $self->store_rrs($dns_packet->additional); |
186
|
|
|
|
|
|
|
print STDERR "DEBUG: Storing cache for [$key;structure]\n"; |
187
|
|
|
|
|
|
|
$self -> {dns_cache} -> {"$key;structure"} = freeze \@s; |
188
|
|
|
|
|
|
|
$self->flush_expired_ttls; |
189
|
|
|
|
|
|
|
untie (%{ $self -> {dns_cache} }) if tied %{ $self -> {dns_cache} }; |
190
|
|
|
|
|
|
|
$lock->close(); |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
return 1; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# Subroutine: store_rrs |
196
|
|
|
|
|
|
|
# PreConds: Takes a list of RR objects |
197
|
|
|
|
|
|
|
# PostConds: Stores rdatastr components into cache |
198
|
|
|
|
|
|
|
# and returns a list of uniques |
199
|
|
|
|
|
|
|
sub store_rrs { |
200
|
|
|
|
|
|
|
my $self = shift; |
201
|
|
|
|
|
|
|
my $answer_hash = {}; |
202
|
|
|
|
|
|
|
foreach my $rr (@_) { |
203
|
|
|
|
|
|
|
my $key = join("\t",$rr->name.".",$rr->class,$rr->type); |
204
|
|
|
|
|
|
|
my $rdatastr = $rr->rdatastr(); |
205
|
|
|
|
|
|
|
my $ttl = $rr->ttl(); |
206
|
|
|
|
|
|
|
if (!exists $answer_hash->{$key}) { |
207
|
|
|
|
|
|
|
$answer_hash->{$key} = []; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
push @{$answer_hash->{$key}}, |
210
|
|
|
|
|
|
|
[$ttl + time, $rdatastr]; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
foreach my $key (keys %{$answer_hash}) { |
213
|
|
|
|
|
|
|
print STDERR "DEBUG: Storing lookup cache for [$key;lookup] (".(scalar @{$answer_hash->{$key}})." elements)\n"; |
214
|
|
|
|
|
|
|
# Save the rdatastr values into the lookup cache |
215
|
|
|
|
|
|
|
$self->{dns_cache}->{"$key;lookup"} = freeze $answer_hash->{$key}; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
return [keys %{$answer_hash}]; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
# Called once prior to server shutdown |
221
|
|
|
|
|
|
|
sub cleanup { |
222
|
|
|
|
|
|
|
my $self = shift; |
223
|
|
|
|
|
|
|
unlink "$self->{dbm_file}.LOCK"; |
224
|
|
|
|
|
|
|
if ($self -> {fresh}) { |
225
|
|
|
|
|
|
|
# This should handle most kinds of db formats. |
226
|
|
|
|
|
|
|
unlink("$self->{dbm_file}", |
227
|
|
|
|
|
|
|
"$self->{dbm_file}.db", |
228
|
|
|
|
|
|
|
"$self->{dbm_file}.dir", |
229
|
|
|
|
|
|
|
"$self->{dbm_file}.pag"); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
return 1; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
sub flush_expired_ttls { |
235
|
|
|
|
|
|
|
my $self = shift; |
236
|
|
|
|
|
|
|
my $now = time; |
237
|
|
|
|
|
|
|
return unless $now > $expiration_check; |
238
|
|
|
|
|
|
|
my ($next_expiration_check, $lookup, $cache); |
239
|
|
|
|
|
|
|
$next_expiration_check = undef; |
240
|
|
|
|
|
|
|
while (($lookup,$cache) = each %{ $self -> {dns_cache} }) { |
241
|
|
|
|
|
|
|
$cache = thaw $cache; |
242
|
|
|
|
|
|
|
next unless ref $cache eq "ARRAY"; |
243
|
|
|
|
|
|
|
if ($lookup =~ /^(.+)\;lookup$/) { |
244
|
|
|
|
|
|
|
my $rr_string = $1; |
245
|
|
|
|
|
|
|
foreach my $entry (@$cache) { |
246
|
|
|
|
|
|
|
if (ref $entry eq "ARRAY") { |
247
|
|
|
|
|
|
|
my $expires = $entry->[0]; |
248
|
|
|
|
|
|
|
if ($expires < $now) { |
249
|
|
|
|
|
|
|
# Contains a TTL in the past |
250
|
|
|
|
|
|
|
# so throw the whole thing out |
251
|
|
|
|
|
|
|
delete $self -> {dns_cache} -> {"$rr_string;lookup"}; |
252
|
|
|
|
|
|
|
last; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
if ($expires > $expiration_check && |
255
|
|
|
|
|
|
|
(!$next_expiration_check || |
256
|
|
|
|
|
|
|
$expires < $next_expiration_check)) { |
257
|
|
|
|
|
|
|
$next_expiration_check = $expires; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
$expiration_check = $next_expiration_check || undef; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
1; |
267
|
|
|
|
|
|
|
__END__ |