Attachment 'srv-redir-0.4.pl'
Download 1 #!/usr/bin/perl
2 #
3 # Author and (C): Francesco Chemolli <kinkie@squid-cache.org>
4 #
5 # Version 0.4
6 #
7 # This redirector implement a working proof-of-concept for using
8 # DNS "SRV" type records to locate origin servers.
9 #
10 # RFC2782-compliant
11 # NOT compliant to andrews' draft yet
12 #
13 # For specifications see:
14 # http://www.ietf.org/rfc/rfc2782.txt
15 # http://www.anta.net/nic/draft-andrews-http-srv-01.shtml
16 #
17 #
18 #
19 # This program is free software; you can redistribute it and/or modify
20 # it under the terms of the GNU General Public License as published by
21 # the Free Software Foundation; either version 2 of the License, or
22 # (at your option) any later version.
23 #
24 # This program is distributed in the hope that it will be useful,
25 # but WITHOUT ANY WARRANTY; without even the implied warranty of
26 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
27 # GNU General Public License for more details.
28 #
29 # You should have received a copy of the GNU General Public License
30 # along with this program; if not, write to the Free Software
31 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
32 #
33 #
34 # Revision history:
35 # 0.2: First released version. Works, negative caching implented.
36 # 0.4: Implemented positive caching and DNS caching
37 # Implementd peer selection algorithm and session affinity
38
39 ########## TUNEABLES ###########
40 my $negative_cache_ttl=60; #seconds
41 my $debug_enabled=0;
42
43 ######## TUNEABLES END #########
44 my %negative_cache=(); #format: hostname -> expiry_timestamp. If host is here
45 # no SRV records are available for it
46 my %dnscache=();
47 #format: "hostname" -> { 'exp' => expiry_timestamp, 'data' => \@ Net::DNS::SRV}
48 my %positive_cache=();
49 #format: (request) "clientip/req_hostname" -> (
50 # "exp" => expiry_timestamp,
51 # "data" => ( @ of "host:port" in preference order)
52 # )
53 # NOTE: we can't really determine an origin server's availability,
54 # so we'll fake it.
55
56 $|=1;
57 use URI::URL;
58 use Net::DNS;
59 use Data::Dumper;
60 use Socket qw(inet_aton);
61
62 my $res=Net::DNS::Resolver->new;
63
64 my ($url, $addr, $fqdn, $ident, $method);
65 while (<>) {
66 chomp;
67 dbg ("got string '$_'");
68 ($url, $addr, $fqdn, $ident, $method,$extra) = m:(\S*) (\S*)/(\S*) (\S*) (\S*) ?(.*):;
69
70 # only apply to HTTP, it's a POC after all
71 unless ($url =~ m!^http://!) {
72 print "\n";
73 dbg("url '$url' is not http.Skipping");
74 next;
75 }
76 #normalize URL
77 $url = url $url; # also removes default port number
78 unless (defined $url) {
79 print "\n";
80 dbg("couldn't parse url. Skipping");
81 next;
82 }
83
84 #TODO: handle the case of nonstandard ports as per specs.
85 $host=lc ($url->host);
86 dbg ("got host $host");
87
88 #TODO: every once in a while sweep the cache to get rid of junk
89 #TODO: use shared memory for the cache?
90 if (negative_cache_lookup($host)) {
91 dbg("negative cache lookup hit. Preserving request");
92 print "\n";
93 next;
94 }
95
96 my $orgins;
97 unless ($origins=positive_cache_lookup($host,$addr)) {
98 #positive cache miss
99 my ($records,@records);
100
101 unless ($records=dnscache_lookup($host)) {
102 #dns cache miss
103 my $query=$res->query("_http._tcp.$host","SRV");
104
105 unless (defined $query) { #no srv-record. return.
106 dbg("DNS lookup failed. Preserving request");
107 print "\n";
108 negative_cache_store($host);
109 next;
110 }
111 #rrsort also filters by RRtype
112 @records=Net::DNS::rrsort("SRV","priority",
113 $query->answer);
114 if ($#records == -1) { #empty result-set. return
115 print "\n";
116 dbg("No DNS SRV records. Preserving request");
117 negative_cache_store($host);
118 next;
119 }
120
121 #store into cache
122 $records=\@records;
123 dnscache_store($host,$records);
124 }
125 #$records now contains a ref to array (RRset), or we can't
126 # have reached this point
127 $origins=build_cache_entry(@{$records});
128 positive_cache_store($host,$addr,$records[0]->ttl,$origins);
129 }
130
131 my $parent=choose_parent($origins);
132 dbg ("got new parent: $parent");
133
134 $url->host(lc $parent); #will it stick? We're also sending the port..
135 print $url."\n"; #host found. redirect.
136 dbg ("sending $url");
137 }
138
139 #in: output of Net::DNS::rrsort
140 #out: ref to data ready to be added to positive cache.
141 # Assumption: TTL is held the same for all SRV records in the rrset
142 sub build_cache_entry {
143 my (%rv)=();
144 $rv{exp}=time+$_[0]->ttl;
145 foreach (@_) {
146 $_->{myweight}=rand($_->{weight});
147 }
148 my @sarr=sort
149 { $a->{'priority'} <=> $b->{'priority'} ||
150 $b->{'myweight'} <=> $a->{'myweight'} }
151 @_;
152 my @data=();
153 my @dbgdata=();
154 foreach(@sarr) {
155 push @data,$_->target.":".$_->port;
156 if ($debug_enabled) {
157 push @dbgdata,$_->target.":".$_->port."(p:".
158 $_->priority.",w:".$_->weight.",pw:".
159 $_->myweight;
160 }
161 }
162 $rv{data}=\@data;
163 if ($debug_enabled) {dbg("cached targets: ".Dumper(\@dbgdata));}
164 else {dbg("cached targets: ".Dumper(\@data)); }
165
166 dbg ("cached entry: ".Dumper(\%rv));
167 return \%rv;
168 }
169
170 #TODO: squid should consider dead peers here.
171 #in: ref to positively-cached target
172 #out:
173 sub choose_parent {
174 my ($entry)=@_;
175 dbg("choose_parent;\nEntry: ".Dumper($entry)."\n");
176
177 #we know that the entry has not expired.
178 return $entry->{data}->[0];
179 }
180
181 #in: string to be printed, without ending lf
182 sub dbg {
183 return unless $debug_enabled;
184 print STDERR "dns-redir[$$]: ",$_[0],"\n";
185 }
186
187 #in: array of numbers
188 #out: sum of those numbers
189 sub sum {
190 my $rv=0;
191 while ($_=shift @_) {$rv+=$_;}
192 return $rv;
193 }
194
195
196 #in: hostname
197 #out: true if there is a negative cache entry for that host
198 sub negative_cache_lookup {
199 my ($host)=@_;
200 if (exists $negative_cache{$host} && $negative_cache{$host} > time) {
201 dbg("negative cache hit for $host");
202 return 1;
203 }
204 dbg("negative cache miss for $host");
205 return 0;
206 }
207
208 #in: hostname
209 sub negative_cache_store {
210 my ($host)=@_;
211 $negative_cache{$host}=time+$negative_cache_ttl;
212 }
213
214 #in: hostname
215 #out: ref to array of Net::DNS::RR::SRV for the relevant domain,
216 # or undef if miss
217 sub dnscache_lookup {
218 my ($host)=@_;
219 if (exists $dnscache{$host} && $dnscache{$host}->{'exp'} > time) {
220 dbg("dns cache hit for$host");
221 return $dnscache{$host}->{'data'};
222 }
223 dbg("dns cache miss for $host");
224 return undef;
225 }
226
227 #in: hostname, \@ Net::DNS::RR::SRV
228 #out: none
229 sub dnscache_store {
230 my ($host,$rrset)=@_;
231 my $expiry=time+(@{$rrset}[0])->ttl;
232 my $entry={ exp => $expiry, data => $rrset };
233 $dnscache{$host}=$entry;
234 }
235
236 sub dnscache_cleanup {
237 my ($k,$v);
238 my $t=time;
239 my $count=0;
240 while ( ($k,$v) = each %dnscache) {
241 if ($v->{'exp'} < $t) {
242 delete($dnscache{$k});
243 $count++;
244 }
245 }
246 dbg("dnscache_cleanup done. Cleaned $count entries");
247 }
248
249 #in: sought-for host, client ip
250 #out: ref to array of strings containing host:port, or undef
251 sub positive_cache_lookup {
252 my ($host,$ip)=@_;
253 my $cachekey="$host/$ip";
254 if (exists $positive_cache{$cachekey} &&
255 $positive_cache{$cachekey}->{'exp'} > time ) {
256 dbg("positive_cache hit for $host/$ip");
257 return $positive_cache{$cachekey}->{'data'};
258 }
259 dbg("positive_cache miss for $host/$ip");
260 return undef;
261 }
262 #in: host, client ip, ttl, ref to array of strings containing host:port
263 sub positive_cache_store {
264 my ($host,$ip,$ttl,$val)=@_;
265 my $cachekey="$host/$ip";
266 $positive_cache{$cachekey}={
267 'exp' => time+$ttl,
268 'data' => $val
269 };
270 }
271
272 sub positive_cache_clean {
273 my ($k,$v);
274 my $t=time;
275 my $count=0;
276 while ( ($k,$v) = each %positive_cache) {
277 if ($v->{'exp'} < $t) {
278 delete($positive_cache{$k});
279 $count++;
280 }
281 }
282 dbg("positive_cache_cleanup done. Cleaned $count entries");
283 }
Attached Files
To refer to attachments on a page, use attachment:filename, as shown below in the list of files. Do NOT use the URL of the [get] link, since this is subject to change and can break easily.You are not allowed to attach a file to this page.