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 }