1 #!/usr/bin/perl
   2 #
   3 # Author and (C): Francesco Chemolli <kinkie@squid-cache.org>
   4 #
   5 # This redirector implement a working proof-of-concept for using
   6 #  DNS "SRV" type records to locate origin servers.
   7 #
   8 # For specifications see:
   9 #      http://www.ietf.org/rfc/rfc2782.txt
  10 #      http://www.anta.net/nic/draft-andrews-http-srv-01.shtml
  11 #
  12 #
  13 #
  14 #  This program is free software; you can redistribute it and/or modify
  15 #  it under the terms of the GNU General Public License as published by
  16 #  the Free Software Foundation; either version 2 of the License, or
  17 #  (at your option) any later version.
  18 #
  19 #  This program is distributed in the hope that it will be useful,
  20 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 #  GNU General Public License for more details.
  23 #
  24 #  You should have received a copy of the GNU General Public License
  25 #  along with this program; if not, write to the Free Software
  26 #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
  27 
  28 ########## TUNEABLES ###########
  29 my $negative_cache_ttl=60; #seconds
  30 my $debug_enabled=0;
  31 
  32 ######## TUNEABLES END #########
  33 my %negative_cache; #format: hostname -> expiry_timestamp
  34 my %positive_cache; #format: hostname -> { "exp" => expiry_timestamp }
  35 
  36 
  37 $|=1;
  38 use URI::URL;
  39 use Net::DNS;
  40 use Data::Dumper;
  41 
  42 my $res=Net::DNS::Resolver->new;
  43 
  44 my ($url, $addr, $fqdn, $ident, $method);
  45 while (<>) {
  46 	chomp;
  47 	dbg ("got string '$_'");
  48 	($url, $addr, $fqdn, $ident, $method,$extra) = m:(\S*) (\S*)/(\S*) (\S*) (\S*) ?(.*):;
  49 
  50 	# only apply to HTTP, it's a POC after all
  51 	unless ($url =~ m!^http://!) {
  52 		dbg("url '$url' is not http.Skipping");
  53 		print "\n";
  54 		next;
  55 	}
  56 	#normalize URL
  57 	$url = url $url;                    # also removes default port number
  58 	unless (defined $url) {
  59 		dbg("couldn't parse url. Skipping");
  60 		print "\n";
  61 		next;
  62 	}
  63 	
  64 	#TODO: handle the case of nonstandard ports as per specs.
  65 	$host=lc ($url->host);
  66 	dbg ("got host $host");
  67 	
  68 	#TODO: every once in a while sweep the cache to get rid of junk
  69 	#TODO: use shared memory for the cache?
  70 	if (exists $negative_cache{$host} && $negative_cache{$host} > time) {
  71 		dbg ("negative cache hit");
  72 		print "\n";
  73 		next;
  74 	}
  75 	#TODO: add positive caching logic
  76 	my $query=$res->query("_http._tcp.$host","SRV");
  77 	
  78 	unless (defined $query) { #no srv-record. return.
  79 		$negative_cache{$host}=time+$negative_cache_ttl;
  80 		print "\n";
  81 		next;
  82 	}
  83 
  84 	my @records=Net::DNS::rrsort("SRV","priority",$query->answer);
  85 	dbg("records: ".Dumper(@records));
  86 	if ($#records == -1) { #empty result-set. return
  87 		print "\n";
  88 		next;
  89 	}
  90 
  91 	#TODO: use more sophisticated logic:
  92 	# load-balancing + session affinity + availability monitoring
  93 	
  94 	$newhost=$records[0]->target;
  95 	$newport=$records[0]->port;
  96 
  97 	$url->host(lc $newhost);
  98 	$url->port($newport);
  99 
 100 	dbg ("sending $url");
 101 	print $url."\n"; #host found. redirect.
 102 }
 103 
 104 
 105 sub dbg {
 106 	return unless $debug_enabled;
 107 	print STDERR "dns-redir[$$]: ",$_[0],"\n";
 108 }