#!/usr/bin/perl

=head1 NAME

 apt-cacher2 - WWW proxy optimized for use with APT

 Copyright (C) 2005 Eduard Bloch <blade@debian.org>
 Copyright (C) 2007 Mark Hindley <mark@hindley.org.uk>
 Distributed under the terms of the GNU Public Licence (GPL).

=head1 SYNOPSIS

 ./setup.pl /home/me/cache
 edit /etc/apt/sources.list (use sources like deb http://proxy:3142/archiveserver/debian ...)
 apt-get update
 apt-get -u upgrade

=head1 DESCRIPTION

If you have two or more Debian GNU/Linux machines on a fast local
network and you wish to upgrade packages from the Internet, you
don't want to download every package several times.

apt-cacher2 is a tiny HTTP proxy that keeps a cache on disk of Debian
binary/source packages and meta files which have been received from Debian
distribution servers on the Internet. When an apt-get client issues
a request for a file to apt-cacher2, if the file is already on disk
it is served to the client immediately, otherwise it is fetched from the
Internet and served to the client while a copy is being stored on the disk.
This means that several Debian machines can be upgraded but each package needs
to be downloaded only once.

apt-cacher2 is a rewrite of the original apt-cacher.pl CGI script, keeping
compatibility in mind. The cached data can be shared by the both
implementations, while apt-cacher2 providers better performance and less server
load.

=head1 INSTALLATION

Assuming your cache server is called B<www.myserver.com>
and your cache directory is called B</home/me/cache>, then:

1. Edit apt-cacher.conf to customize your settings

2. Run apt-cacher2

=cut
# ----------------------------------------------------------------------------

use strict;
use lib '/usr/share/apt-cacher/';

use Fcntl qw(:DEFAULT :flock);
use WWW::Curl::Easy;
use WWW::Curl::Multi;
use FreezeThaw qw(freeze thaw);
use IO::Socket::INET;
use IO::Select;
use HTTP::Response;
use HTTP::Date;
use Sys::Hostname;
use Filesys::DiskSpace;

# Include the library for the config file parser
require 'apt-cacher-lib.pl';

# Set some defaults
my $version='0.1'; # this will be auto-replaced when the Debian package is being built
my $configfile_default = '/etc/apt-cacher/apt-cacher.conf';
my $configfile = $configfile_default;

my $mode; # cgi|inetd|undef

# Needs to be global for &setup_ownership
our $cfg;

my ($aclog_fh, $erlog_fh);
my ($con, $source);

my %pathmap;

# Data shared between functions

my $new_filename;
my $cached_file;
my $cached_head;
my $complete_file;

my $concloseflag;
my @cache_control;

my $listeners;
my @childPids;
my $terminating;

# Function prototypes
sub ipv4_addr_in_list ($$);
sub ipv6_addr_in_list ($$);
sub get_abort_time ();

# Subroutines

sub setup {
    my $pidfile;
    my $chroot;
    my $retnum;
    my $do_fork_away;

    my @extraconfig;

    if($ENV{CGI_MODE}) {
	# yahoo, back to the roots, CGI mode
	$mode='cgi';
    }
    else {
	local @ARGV = @ARGV; # Use a copy so @ARGV not destroyed
	while(scalar (@ARGV)) {

	    my $arg=shift(@ARGV);

	    if($arg eq '-c') {
		$configfile=shift(@ARGV);
		die "$configfile unreadable" if ! -r $configfile;
	    }
	    elsif($arg eq '-r') {
		$chroot=shift(@ARGV);
		die "No such directory: $chroot\n" if ! -d $chroot;
	    }
	    elsif($arg eq '-R') {
		$retnum=shift(@ARGV);
	    }
	    elsif($arg eq '-i') {
		$mode='inetd';
	    }
	    elsif($arg eq '-d') {
		$do_fork_away=1;
	    }
	    elsif($arg eq '-p') {
		$pidfile=shift(@ARGV);
	    }
	    elsif($arg=~/(\S+)=(.+)/) {
		push(@extraconfig, $1, $2);
	    }
	    elsif($arg eq '-h' || $arg eq '--help') {
		print <<EOM;
USAGE: $0 <options> <override(s)>
Options:

-c configfile   Custom config file (default: $configfile_default)
-i              Inetd mode, STDIN and STDOUT are used for service
(default: standalone server mode)
-d              become a background daemon

Advanced options (root only):
-r directory    (experimental option)
		path to chroot to after reading the config and opening the log
		files. cache directory setting must be relative to the new root.
		WARNING: log files should be created before and be owned by tne
		effective user/group if -g or -u are used
-p pidfile      write the server process ID into this file

Overrides:     override config variables (see config file), eg. daemon_port=9999

EOM
		exit(0);
	    }
	    else {
		die "Unknown parameter $arg\n";
	    }
	}
    }

    eval {
	$cfg = read_config($configfile);
    };

    # not sure what to do if we can't read the config file...
    die "Could not read config file: $@" if $@;

    define_global_lockfile("$cfg->{cache_dir}/private/exlock");

    # Now set some things from the command line
    $cfg->{pidfile} = $pidfile if $pidfile;
    $cfg->{fork} = $do_fork_away if $do_fork_away;
    $cfg->{retry} = $retnum if $retnum;
    $cfg->{chroot} = $chroot if $chroot;

    # override config values with the user-specified parameters
    while(@extraconfig) {
	my $k=shift(@extraconfig);
	my $v=shift(@extraconfig);
	$cfg->{$k}=$v;
    }

    # checksum
    require 'apt-cacher-lib-cs.pl' if $cfg->{checksum};

    if($cfg->{path_map}) {
	for(split(/\s*[,;]\s*/, $cfg->{path_map})) {
	    my @tmp = split(/\s+/, $_);
	    # must have at least one path and target
	    next if ($#tmp < 1);
	    my $key=shift(@tmp);
	    $pathmap{$key}=[@tmp];
	}
    }

    if ($cfg->{interface}) {
	# If we can't resolve item, see if it is an interface name
	unless (inet_aton($cfg->{interface})) {
	    use IO::Interface::Simple;
	    my $if = IO::Interface::Simple->new($cfg->{interface});
	    if ($if) {
		$cfg->{interface} = $if->address;
	    }
	    else {
		$cfg->{interface} = '';
	    }
	}
    }

    # Ensure config is sane and filesystem is present and readable
    &check_install;
    # Die if it still failed
    die "$0: No $cfg->{cache_dir}/private directory!\n" if (!-d "$cfg->{cache_dir}/private");

    # Set default path for socket
    $cfg->{libcurl_socket} = "$cfg->{cache_dir}/libcurl.socket" unless $cfg->{libcurl_socket};
}

sub clean_exit {
    debug_message('Clean up before exiting.');
    $terminating=1;

    # close connections, kill children
    $con->close if $con;
    if ($listeners) {
        for ($listeners->handles) {$_->shutdown(2)};
    }

    for(@childPids) {
	&debug_message("killing subprocess: $_");
	kill 15, $_;
    };
    exit(0);
}

sub reload_config {
    info_message('Got SIGHUP, reloading config');
    &setup;
}

sub toggle_debug {
    $cfg->{debug} = !$cfg->{debug};
    info_message('Got SIGUSR1, '.($cfg->{debug} ? 'en':'dis').'abling debug output');
}

sub handle_connection {
    # now begin connection's personal stuff

    my $client;

    debug_message('New '. ($mode ? "\U$mode" : 'Daemon') .' connection');

    if($mode) { # Not standalone daemon
	$source=*STDIN;
	$con = *STDOUT;
	# identify client in the logs.
	if (exists $ENV{REMOTE_ADDR}){ # CGI/apt-cacher-cleanup mode
	    $client=$ENV{REMOTE_ADDR};
	    $cfg->{daemon_port}=$ENV{SERVER_PORT};
	}
	else { # inetd mode
	    $client='INETD';
	    $cfg->{daemon_port} = &get_inetd_port();
    	}
    }
    else { # Standalone daemon mode

	$con = shift;
	$source = $con;
	$client = $con->peerhost;
    }

    if($mode && $mode ne 'inetd') {
	# ----------------------------------------------------------------------------
	# Let's do some security checking. We only want to respond to clients within an
	# authorised address range (127.0.0.1 and ::1 are always allowed).

	my $ip_pass = 1;
	my $ip_fail = 0;
	my $clientaddr;

	# allowed_hosts == '*' means allow all ('' means deny all)
	# denied_hosts == '' means don't explicitly deny any
	# localhost is always accepted
	# otherwise host must be in allowed list and not in denied list to be accepted

	if ($client =~ /:/) # IPv6?
	{
	    defined ($clientaddr = ipv6_normalise ($client)) or goto badaddr;
	    if (substr ($clientaddr, 0, 12) eq "\0\0\0\0\0\0\0\0\0\0\xFF\xFF")
	    {
		$clientaddr = substr ($clientaddr, 12);
		goto is_ipv4;
	    }
	    elsif ($clientaddr eq "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1")
	    {
		debug_message('client is localhost');
	    }
	    else
	    {
		$ip_pass = ($cfg->{allowed_hosts_6} =~ /^\*?$/) ||
		ipv6_addr_in_list ($clientaddr, 'allowed_hosts_6');
		$ip_fail = ipv6_addr_in_list ($clientaddr, 'denied_hosts_6');
	    }
	}
	elsif (defined ($clientaddr = ipv4_normalise ($client))) # IPv4?
	{
	    is_ipv4:
	    if ($clientaddr eq "\x7F\0\0\1")
	    {
		debug_message('client is localhost');
	    }
	    else
	    {
		$ip_pass = ($cfg->{allowed_hosts} =~ /^\*?$/) ||
		ipv4_addr_in_list ($clientaddr, 'allowed_hosts');
		$ip_fail = ipv4_addr_in_list ($clientaddr, 'denied_hosts');
	    }
	}
	else
	{
	    goto badaddr;
	}

	# Now check if the client address falls within this range
	if ($ip_pass && !$ip_fail)
	{
	    # Everything's cool, client is in allowed range
	    debug_message("Client $client passed access control rules");
	}
	else
	{
	    # Bzzzt, client is outside allowed range. Send a 403 and bail.
	    badaddr:
	    debug_message("Alert: client $client disallowed by access control");
	    &sendrsp(403, 'Access to cache prohibited');
	    exit(4);
	}
    }

    REQUEST:
    while(!$concloseflag) {

	my $path;
	my $testpath; # temporary, to be set by GET lines, undef on GO
	my $filename;
	my $ifmosince;# to be undef by new GET lines
	my $send_head_only=0; # to be undef by new GET lines
	my $tolerated_empty_lines=20;
	my $rangereq;
	my $hostreq;
	my $httpver;
	my $force_download=0;
	my $cache_status;
	@cache_control = (); # Start with empty list

	# reading input line by line, through the secure input method
	CLIENTLINE: while(1) {

	    debug_message('Processing a new request line');

	    $_=&getRequestLine;

	    if (!defined($_)) {
		exit(0) if $mode && $mode eq 'cgi';
		&sendrsp(400, 'No Request Received');
		exit(4);
	    }

	    debug_message("got: $_");

	    if(/^$/) {
		if(defined($testpath)) {
		    # done reading request
		    $testpath="http://$ENV{SERVER_NAME}/$testpath" if $mode && $mode eq 'cgi';
		    $path=$testpath;
		    last CLIENTLINE;
		}
		elsif(!$tolerated_empty_lines)   {
		    &sendrsp(403, 'Go away');
		    exit(4);
		}
		else {
		    $tolerated_empty_lines--;
		}
	    }
	    else {

		if(/^(GET|HEAD)\s+(\S+)(?:\s+HTTP\/(\d\.\d))?/) {
		    if(defined($testpath)) {
			&sendrsp(403, 'Confusing request');
			exit(4);
		    }
		    $testpath=$2;
		    $httpver=$3;
		    # also support pure HEAD calls
		    if($1 eq 'HEAD') {
			$send_head_only=1;
		    }
		}
		elsif(/^Host:\s+(\S+)/) {
		    $hostreq=$1;
		}
		elsif(/^((?:Pragma|Cache-Control):\s+\S+)/) {
		    debug_message("Request specified $1");
		    push @cache_control, $1;
		    if ($1=~/no-cache/) {
			$cache_status = 'EXPIRED';
			debug_message("Download forced");
		    }
		}
		elsif(/^Connection: close/i) {
		    $concloseflag=1;
		}
		elsif(/^Connection: .*TE/) {
		    $concloseflag=1;
		}
		elsif(/^Range/i) {
		    $rangereq=1;
		}
		elsif(/^If-Modified-Since:\s+(.*)/i) {
		    $ifmosince=$1;
		}
		elsif(/^\S+: [^:]*/) {
		    # whatever, but valid
		}
		else {
		    info_message("Failed to parse input: $_");
		    &sendrsp(403, "Could not understand $_");
		    exit(4);
		}
	    }
	}

	# RFC2612 requires bailout for HTTP/1.1 if no Host
	if ($httpver && $httpver>=1.1 && !$hostreq) {
	    &sendrsp(400, 'Host Header missing');
	    exit(4);
	}

	# always resend the file if a part was requested since we don't support ranges
	$ifmosince=0 if $rangereq;

	# Decode embedded ascii codes in URL
	$path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;

	if ($path =~ m!^http://([^/]+)!) { # Absolute URI
	    # Check host or proxy
	    debug_message("Checking host $1 in absolute URI");
	    my %sockopt = (PeerAddr=> $1, # possibly with port
			   PeerPort=> 80, # Default, overridden if
					  # port also in PeerAddr
			   Proto   => 'tcp');
	    $sockopt{LocalAddr} = $cfg->{interface} if $cfg->{interface};
	    my $sock = io_socket_inet46(%sockopt);
	    # proxy may be required to reach host
	    if (!defined($sock) && !$cfg->{use_proxy}) {
		info_message("Unable to connect to $1");
		&sendrsp(404, "Unable to connect to $1");
		exit(4);
	    }
	    # Both host and port need to be matched.  In inetd mode daemon_port
	    # is read from inetd.conf by get_inetd_port(). In CGI mode it is
	    # set from SERVER_PORT.
	    if (defined($sock) &&
		$sock->sockhost =~ $sock->peerhost &&
		$sock->peerport == $cfg->{daemon_port}) { # Host is this host
		debug_message('Host in Absolute URI is this server');
		$path =~ s!^http://[^/]+!!; # Remove prefix and hostname
	    }
	    else { # Proxy request
		debug_message('Host in Absolute URI is not this server');
		$path =~ s!^http:/!!; # Remove absolute prefix
	    }
	    defined($sock) && $sock->shutdown(2); # Close
	}

	# tolerate CGI specific junk and multiple slashes in the beginning
	$path =~ s!^/apt-cacher\??/!/!;
	$path =~ s!^/+!/!;

	debug_message("Resolved request is $path");

	# Now parse the path
	if ($path =~ /^\/?report/) {
	    usage_report();
	    exit(0);
	}

	if ($path !~ m(^/?.+/.+)) {
	    usage_error($client);
	}

	REPARSE:
	my($host,$uri) = ($path =~ m#^/?([^/]+)(/.+)#);

	if ( !$host || !$uri ) {
	    usage_error($client);
	}

	$uri =~ s#/{2,}#/#g; # Remove multiple separators
	($filename) = ($uri =~ /\/?([^\/]+)$/);

	unless ($filename) {
	    debug_message("No filename in request $uri. Skipping");
	    &sendrsp(403, 'Sorry, no filename given. Proxy for directories not permitted');
	    next REQUEST;
	}

	if($cfg->{allowed_locations}) {
	    #         debug_message('Doing location check for '.$cfg->{allowed_locations} );
	    my $mess;
	    my $cleanuri=$uri;
	    $cleanuri=~s!/[^/]+/[\.]{2}/!/!g;
	    if ($host eq '..' ) {
		$mess = q!'..' contained in the hostname!;
	    }
	    elsif ($cleanuri =~/\/\.\./) {
		$mess = 'File outside of the allowed path';
	    }
	    else {
		for( split(/\s*[;,]\s*/,$cfg->{allowed_locations}) ) {
		    debug_message("Testing URI: $host$cleanuri on $_");
		    goto location_allowed if ("$host$cleanuri" =~ /^$_/);
		}
		$mess = "Host '$host' is not configured in the allowed_locations directive";
	    }
	    badguy:
	    debug_message("$mess; access denied");
	    &sendrsp(403, "Access to cache prohibited, $mess");
	    exit(4);
	}
	location_allowed:

	if (&is_package_file($filename)){
	    # We must be fetching a .deb or a .rpm or some other recognised
	    # file, so let's cache it.
	    # Place the file in the cache with just its basename
	    $new_filename = $filename;
	    debug_message("new base file: $new_filename");
	}
	elsif ($filename =~ /2\d\d\d-\d\d-\d\d.*\.gz$/) {
	    # a patch file. Needs a unique filename but no freshness checks
	    $new_filename = "$host$uri";
	    $new_filename =~ s/\//_/g;
	    debug_message("new pdiff file: $new_filename");
	}
	elsif (is_installer_file($filename)) {
	    # Installer or Debian-live files
	    # Need to be long names, but not index
	    $new_filename = "$host$uri";
	    $new_filename =~ s/\//_/g;
	    debug_message("new installer file: $new_filename");
	}
	elsif (&is_index_file($filename)) {
	    # It's a Packages.gz or related file: make a long filename so we can
	    # cache these files without the names colliding
	    $new_filename = "$host$uri";
	    $new_filename =~ s/\//_/g;
	    debug_message("new index file: $new_filename");
	} else {
	    # Maybe someone's trying to use us as a general purpose proxy / relay.
	    # Let's stomp on that now.
	    debug_message("Sorry, not allowed to fetch that type of file: $filename");
	    &sendrsp(403, "Sorry, not allowed to fetch that type of file: $filename");
	    exit(4);
	}

	$cached_file = "$cfg->{cache_dir}/packages/$new_filename";
	$cached_head = "$cfg->{cache_dir}/headers/$new_filename";
	$complete_file = "$cfg->{cache_dir}/private/$new_filename.complete";

	debug_message("looking for $cached_file");

	if (&is_index_file($filename)) {
	    debug_message("known as index file: $filename");
	    # in offline mode, if not already forced deliver it as-is, otherwise check freshness
	    if ((!$cache_status || $cache_status ne 'EXPIRED') && -f $cached_file && -f $cached_head && !$cfg->{offline_mode}) {
		if($cfg->{expire_hours} > 0) {
		    my $now = time();
		    my @stat = stat($cached_file);
		    if (@stat && int(($now - $stat[9])/3600) > $cfg->{expire_hours}) {
			debug_message("unlinking $new_filename because it is too old");
			# Set the status to EXPIRED so the log file can show it
			# was downloaded again
			$cache_status = 'EXPIRED';
			debug_message($cache_status);
		    }
		}
		else {
		    # use HTTP timestamping/ETag
		    my ($oldmod,$newmod,$oldtag,$newtag,$testfile);
		    my $response = ${&libcurl($host, $uri, undef)}; # HEAD only
		    if($response->is_success) {
		      $newmod = $response->header('Last-Modified');
		      $newtag = $response->header('ETag');
		      if(($newmod||$newtag) && open($testfile, $cached_head)) {

			  for ($newmod,$newtag) {
			      s/[\n\r]//g if $_;
			  }

			  for(<$testfile>){
			      if(/^.*Last-Modified:\s(.*)(?:\r|\n)/) {
				  $oldmod = $1;
			      }
			      elsif (/^.*ETag:\s*(.*)(?:\r|\n)/) {
				  $oldtag = $1;
			      }
			      last if $oldtag && $oldmod;
			  }
			  close($testfile);
		      }
		      # Don't use ETag by default for now: broken on some servers
		      if($cfg->{use_etags} && $oldtag && $newtag) { # Try ETag first
			  if ($oldtag eq $newtag) {
			      debug_message("ETag headers match, $oldtag <-> $newtag. Cached file unchanged");
			  }
			  else {
			      debug_message("ETag headers different, $oldtag <-> $newtag. Refreshing cached file");
			      $cache_status = 'EXPIRED';
			      debug_message($cache_status);
			  }
		      }
		      else {
			  if($oldmod && $newmod && (str2time($oldmod) >= str2time($newmod)) ) {
			      # that's ok
			      debug_message("cached file is up to date or more recent, $oldmod <-> $newmod");
			  }
			  else {
			      if ($oldmod && $newmod) {
				  debug_message("downloading $new_filename because more recent version is available: $oldmod <-> $newmod");
			      }
			      else {
				  debug_message("downloading $new_filename because modification information incomplete");
			      }
			      $cache_status = 'EXPIRED';
			      debug_message($cache_status);
			  }
		      }
		  }
		    else {
			debug_message('HEAD request error: '.$response->status_line.' Reusing existing file');
			$cache_status = 'OFFLINE';
		    }
		}
	    }
	}
	
	# handle if-modified-since in a better way (check the equality of
	# the time stamps). Do only if download not forced above.

	if($ifmosince && (!$cache_status || $cache_status ne 'EXPIRED')) {
	    $ifmosince=~s/\n|\r//g;

	    my $oldhead;
	    if(open(my $testfile, $cached_head)) {
	      LINE: for(<$testfile>){
		    if(/^.*Last-Modified:\s(.*)(?:\r|\n)/) {
			$oldhead = $1;
			last LINE;
		    }
		}
		close($testfile);
	    }

	    if($oldhead && str2time($ifmosince) >= str2time($oldhead)) {
		&sendrsp(304, 'Not Modified');
		debug_message("File not changed: $ifmosince");
		next REQUEST;
	    }
	}

	&set_global_lock(': file download decision'); # file state decisions, lock that area

	my $fromfile; # handle for return_file()

	# download or not decision. Also releases the global lock
	dl_check:
	if( !$force_download && -e $cached_head && -e $cached_file && (!$cache_status||$cache_status eq 'OFFLINE')) {
	    sysopen($fromfile, $cached_file, O_RDONLY) ||
	      barf("Unable to open $cached_file: $!.");
	    unless ($cache_status && $cache_status eq 'OFFLINE') {
		# not much to do if complete
		if (!-f $complete_file) {
		    # a fetcher was either not successful or is still running
		    # look for activity...
		    if (flock($fromfile, LOCK_SH|LOCK_NB)) {
			flock($fromfile, LOCK_UN);
			# No fetcher working on this package. Redownload it.
			close($fromfile);
			undef $fromfile;
			debug_message('no fetcher running, downloading');
			$force_download=1;
			goto dl_check;
		    }
		    else {
			debug_message('Another fetcher already working on file');
		    }
		}
		$cache_status = 'HIT';
		debug_message($cache_status);
	    }
	    &release_global_lock;
	}
	else {
	    # bypass for offline mode, no forking, just report the "problem"
	    if($cfg->{offline_mode})
	    {
		&release_global_lock;
		&sendrsp(503, 'Service not available: apt-cacher offline');
		next REQUEST;
	    }
	    # (re) download them
	    unlink($cached_file, $cached_head, $complete_file);
	    debug_message('file does not exist or download required, forking fetcher');

	    # Set the status to MISS so the log file can show it had to be downloaded
	    # except on special presets from index file checks above
	    if(!defined($cache_status)) {
		$cache_status = 'MISS';
		debug_message($cache_status);
	    }

	    # Need separate filehandles for reading and writing,
	    # relying on dup at the fork leaves a shared seek pointer
	    sysopen(my $pkfd, $cached_file, O_RDWR|O_CREAT|O_EXCL, 0644)
	      || barf("Unable to create new $cached_file: $!");
	    $pkfd->autoflush;
	    sysopen($fromfile, $cached_file, O_RDONLY)
	      || barf("Unable to open $cached_file: $!.");

	    my $pid = fork();
	    if ($pid < 0) {
		barf('fork() failed');
	    }
	    if ($pid == 0) {
		# child, the fetcher thread
		undef @childPids;
		$0="$0 [$host$uri]"; # Visible to ps and friends
		close($fromfile);
		
		# jump from the global lock to a lock on the target file
		flock($pkfd, LOCK_EX) || barf('Unable to lock the target file');
		&release_global_lock;

		&fetch_store ($host, $uri, \$pkfd);
		exit(0);
	    }
	    # parent continues
	    push @childPids, $pid;
	    debug_message("registered child process: $pid");
	    close($pkfd);
	}

	debug_message('checks done, can return now');

	my $ret = &return_file ($send_head_only ? undef : \$fromfile);
	if ($ret && $ret==2) { # retry code
	    debug_message('return_file requested retry');
	    goto dl_check;
	}
	debug_message('Package sent');

	# Write all the stuff to the log file
	writeaccesslog($cache_status, $new_filename, $client);
    }
}

sub return_file {
    # At this point the file is open, and it's either complete or somebody
    # is fetching its contents

    my $fromfile=${$_[0]} if $_[0];
    my $header_printed=0;

    &data_init;

    my $abort_time = get_abort_time();
    my $buf;

    my $geslen=0;
    my $curlen=0;
    my $explen;

    my $fetcher_done;

    # needs to print the header first
    CHUNK: while (1) {

	#debug_message('Send loop iteration:');

	if (time() > $abort_time) {
	    info_message("return_file $cached_file aborted by timeout at $curlen of $explen bytes");
	    &sendrsp(504, 'Request Timeout') if !$header_printed;
	    exit(4);
	}

	if(!$header_printed) {

	    if(-s $cached_head) {
		# header file seen, protect the reading
		&set_global_lock(': reading the header file');
		if(! -f $cached_head) {
		    # file removed while waiting for lock - download failure?!
		    # start over, maybe spawning another fetcher
		    &release_global_lock;
		    return(2); # retry
		}

		open(my $in, $cached_head) || die $!;
		my $code=200;
		my $msg='';
		my $headstring='';

		$headstring=<$in>; # read exactly one status line

		($code, $msg) = ($headstring=~/^HTTP\S+\s+(\d+)\s(.*)/);
		# alternative for critical errors
		if(!defined($code)) {
		    ($code, $msg) = ($headstring=~/^(5\d\d)\s(.*)/);
		}

		if(!defined($code)) {
		    info_message("Faulty header file detected: $cached_head, first line was: $headstring");
		    unlink $cached_head;
		    &sendrsp(500, 'Internal Server Error');
		    exit(3);
		}

		# in CGI mode, use alternative status line. Don't print one
		# for normal data output (apache does not like that) but on
		# abnormal codes, and then exit immediately
		if($mode && $mode eq 'cgi') {
		    # don't print the head line but a Status on errors instead
		    $headstring=~s/^HTTP\S+/Status:/;
		    if($code == 200) {
			$headstring=''; # kick headline by default
		    }
		    else {
			print $con $headstring."\n\n";
			exit(1);
		    }
		}

		# Keep alive or not? Follow the client
		$headstring .= 'Connection: '.($concloseflag ? 'Close' : 'Keep-Alive')."\r\n";

		# keep only parts interesting for apt
		if ($code==200) {
		    for(<$in>) {
			chomp;
			if(/^Last-Modified|Content|Accept|ETag|Age/) {
			    $headstring.=$_."\r\n";
			    if(/^Content-Length:\ *(\d+)/) {
				$explen=$1;
			    }
			}
		    }
		}
		else {
		    $headstring.="Content-Length: 0\r\n";
		}
		close($in);
		&release_global_lock;

		print $con $headstring."\r\n";

		$header_printed=1;
		debug_message("Header sent: $headstring");

		# Stop after sending the header with errors
		return if HTTP::Status::is_error($code);

	    }
	    else {
		sleep(1);
		next CHUNK;
	    }

	    # pure HEAD request, we are done
	    return unless ($fromfile);

	    debug_message("ready to send contents of $cached_file");
	}

	my $n = sysread($fromfile, $buf, 65536);
	debug_message("read $n bytes");

	if(!defined($n)) {
	    debug_message('Error detected, closing connection');
	    exit(4); # Header already sent, can't notify error
	}

	if($n==0) {

	    if($fetcher_done) {
		# comlete file was found in the previous iteration
		# this is the loop exit condition
		#
		# final check on size
		if($explen && $curlen != $explen) {
		    info_message("ALARM! $cached_file file size mismatch (found $curlen, expected $explen). Renaming to $cached_file.corrupted.");
		    unlink "$cached_file.corrupted";
		    rename($cached_file, "$cached_file.corrupted");
		    exit(5); # Header already sent, can't notify error
		}
		# Checksum
		if(!&is_index_file($cached_file) && !check_sum($new_filename,&db)) {
		    info_message("ALARM! $cached_file checksum invalid! Removing.");
		    unlink $cached_file;
		    exit(5); # Header already sent, can't notify error
		}
		last CHUNK;
	    }

	    if (flock($fromfile,LOCK_SH|LOCK_NB)) {
		flock($fromfile,LOCK_UN);
		# do another iteration, may need to read remaining data
		debug_message('fetcher released lock');
		$fetcher_done=1;
		next CHUNK;
	    }

	    # debug_message('waiting for new data');
	    # wait for fresh data
	    sleep(1);
	    next CHUNK;

	}
	else {
	    $curlen+=$n;
	    if($explen && $curlen > $explen) {
		info_message("ALARM! $cached_file file is larger than expected ($explen). Renaming to $cached_file.corrupted.");
		unlink "$cached_file.corrupted";
		rename($cached_file, "$cached_file.corrupted");
		exit(5); # Header already sent, can't notify error
	    }
	    #debug_message("write $n / $curlen bytes");
	    # send data and update watchdog
	    print $con $buf;
	    debug_message("wrote $n (sum: $curlen) bytes");
	    $abort_time = get_abort_time();
	    data_feed(\$buf);
	}
    }
}

sub usage_error {
    my $hosturl;
    my $modestr;
    if ($mode && $mode eq 'cgi') {
	$hosturl = hostname . '/[cgi-bin/]apt-cacher';
	$modestr = 'CGI mode';
    }
    else {
	$hosturl = hostname . ':' . $cfg->{daemon_port};
	$modestr = 'Daemon mode';
	$modestr .= ' [inetd]' if ($mode && $mode eq 'inetd');
    }

    &open_log_files;
	writeerrorlog("$_[0]|--- $0: Usage error");

    &sendrsp(200, 'OK', 'Content-Type', 'text/html', 'Expires', 0);
	print $con <<EOF;

<html>
<title>Apt-cacher version $version: $modestr</title>
<style type="text/css"><!--
a { text-decoration: none; }
a:hover { text-decoration: underline; }
h1 { font-family: arial, helvetica, sans-serif; font-size: 18pt; font-weight: bold;}
h2 { font-family: arial, helvetica, sans-serif; font-size: 14pt; font-weight: bold;}
body, td { font-family: arial, helvetica, sans-serif; font-size: 10pt; }
th { font-family: arial, helvetica, sans-serif; font-size: 11pt; font-weight: bold; }
//--></style>
</head>
<body>
<p>
<table border=0 cellpadding=8 cellspacing=1 bgcolor="#000000" align="center" width="600">
<tr bgcolor="#9999cc">
<td>
<h1>Apt-cacher version $version: $modestr</h1>
</td>
</tr>
<tr bgcolor="#cccccc">
<td>
Usage: edit your /etc/apt/sources.list so all your HTTP sources are prepended
with the address of your apt-cacher machine and the port, like this:
<blockquote>deb&nbsp;http://example.debian.org/debian&nbsp;unstable&nbsp;main&nbsp;contrib&nbsp;non-free</blockquote>
becomes
<blockquote>deb&nbsp;http://<b>$hosturl/</b>example.debian.org/debian&nbsp;unstable&nbsp;main&nbsp;contrib&nbsp;non-free</blockquote>
</td>
</tr>
</table>

<h2 align="center">Configuration: $configfile</h2>
<table border=0 cellpadding=3 cellspacing=1 bgcolor="#000000" align="center">
<tr bgcolor="#9999cc"><th> Directive </th><th> Value </th></tr>
EOF
    #Iterate through $cfg and tabulate
    foreach  (sort(keys %$cfg)) {
      print $con "<tr bgcolor=\"#cccccc\" align=\"left\"> \
		<td bgcolor=\"#ccccff\"> $_ </td> \
		<td> $cfg->{$_} </td> \
	     </tr>\n";
    }

    print $con <<EOF;
</table>
<p>
<h2 align="center">License</h2>
<table border=0 cellpadding=8 cellspacing=1 bgcolor="#000000" align="center"
width="600">
<tr bgcolor="#cccccc">
<td>
<p>Apt-cacher is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any later
version.
<p>Apt-cacher is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the GNU General Public License for more details.
<p>A copy of the GNU General Public License is available as
/usr/share/common-licenses/GPL in the Debian GNU/Linux distribution or on the
World Wide Web at http://www.gnu.org/copyleft/gpl.html. You can also obtain it
by writing to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
</td>
</tr>
</table>
</body>
</html>
EOF

    exit(1);
}

# Jon's extra stuff to write the event to a log file.
sub writeaccesslog {
    my $cache_status = shift;
    my $new_filename = shift;
    my $client = shift;

    # The format is 'time|cache status (HIT, MISS or EXPIRED)|client IP address|file size|name of requested file'
    my $time = localtime;
    my $file_length = -s $cached_file || return; # Return if the cached file doesn't exist.
                                                 # Fetch failed or other error

    flock($aclog_fh, LOCK_EX);
    print $aclog_fh "$time|$$|$client|$cache_status|$file_length|$new_filename\n";
    flock($aclog_fh, LOCK_UN);
}

# Jon's extra stuff to write errors to a log file.
sub writeerrorlog {
    my $message = shift;

    my $time = localtime;

    # Prevent double newline
    chomp $message;

    if (!defined $erlog_fh) {
	print STDERR "$message\n"; # Better than nothing
	return;
    }
    flock($erlog_fh, LOCK_EX);
    # files may need to be reopened sometimes - reason unknown yet, EBADF
    # results
    syswrite($erlog_fh,"$time|$message\n") || &open_log_files;
    flock($erlog_fh, LOCK_UN);
}

# Stuff to append debug messages to the error log.
sub debug_message {
    if ($cfg->{debug}) {
	my $message = shift;
	&writeerrorlog("debug [$$]: $message");
    }
}

sub info_message {
    my $message = shift;
    writeerrorlog("info [$$]: $message");
}

sub open_log_files {
    my $logfile = "$cfg->{logdir}/access.log";
    my $errorfile = "$cfg->{logdir}/error.log";

    if(!$erlog_fh) {
	open($erlog_fh,">>$errorfile") or barf("Unable to open $errorfile, $!");
    }
    if(!$aclog_fh) {
	open($aclog_fh,">>$logfile") or barf("Unable to open $logfile, $!");
    }
    # Install signal handlers to capture error messages
    $SIG{__WARN__} = sub {writeerrorlog("warn [$$]: ".shift)};
    $SIG{__DIE__} = sub {writeerrorlog("error [$$]: ".shift)};
}

sub get_abort_time () {
    return time () + $cfg->{fetch_timeout}; # five minutes from now
}

# Arg is ref to HTTP::Response
sub write_header {
    &set_global_lock(": libcurl, storing the header to $cached_head");
    debug_message('Writing header');
    open (my $chfd, ">$cached_head") || barf("Unable to open $cached_head, $!");
    print $chfd ${$_[0]}->as_string;
    close($chfd);
    &release_global_lock;
}

sub debug_callback {
    my ($data, undef, $type) = @_;
    writeerrorlog "debug CURLINFO_"
      .('TEXT','HEADER_IN','HEADER_OUT','DATA_IN','DATA_OUT','SSL_DATA_IN','SSL_DATA_OUT')[$type]
	." [$$]: $data" if ($type < $cfg->{debug});
}

# returns a socket to the libcurl process
sub connect_curlm {
    my $conn;
    # Check for running server
    &set_global_lock(": connect libcurl");
    if ($conn= IO::Socket::UNIX->new($cfg->{libcurl_socket})) {
	debug_message("Connection to running libcurl process found on $cfg->{libcurl_socket}");
	&release_global_lock;
    }
    else {
	my $lc_pid=fork();
	die "fork() for libcurl failed: $!" unless defined $lc_pid;
	if ($lc_pid == 0) {
	    # Child, the libcurl thread
	    debug_message('Init libcurl thread');
	    undef @childPids;
	    $con->close;
	    $source->close;
	    $aclog_fh->close;
	    $0 =~ s/ .*$/ [libcurl]/; # Visible to ps and friends
	    unlink ($cfg->{libcurl_socket});
	    my $server = IO::Socket::UNIX->new(Proto => 'tcp',
					       Local => $cfg->{libcurl_socket},
					       Listen => SOMAXCONN,
					       Reuse => 1)
	      or die "Unable to create libcurl socket $cfg->{libcurl_socket}: $!";
	    chmod 0600, $cfg->{libcurl_socket} or die "Unable to set permissions: $!";

	    &release_global_lock;

	    my $select = IO::Select->new($server) or die "Unable to create select: $!";
	    my $curlm = new WWW::Curl::Multi;
	    my %easy; # hash to hold requests
	    my $active_handles = 0;
	    my $idcounter=1;

	    while ($select->can_read($cfg->{curl_idle_timeout})) {
	      LIBCURL_REQUEST:
		{
		    my $client = $server->accept();
		    debug_message("libcurl: connection from $client");
		    # deal with connection here
		    while (<$client>) {
			chomp;
			my ($curl_req,$headonly,@cache_control) = thaw($_); # Decode request
			debug_message("Libcurl: thawed request $curl_req, $headonly, @cache_control");
			# Verify input
			if ($curl_req !~ m!^http://[-~\w+\.]+!i) {
			    info_message("Error: [libcurl] Bad request received $_");
			    $client->close;
			}
			else {
			    $client->shutdown(0); # Finished reading

			    my $curl = ${&init_curl};
			    $easy{$idcounter}=[$client,$curl];
			    debug_message("Add curl handle #$idcounter: for $curl_req");
			    $curl->setopt(CURLOPT_PRIVATE,$idcounter++); # Assign Multi ID
			    # attach to WWW::Curl::Multi
			    $curlm->add_handle($curl);
			
			    if($headonly) {
				debug_message ('libcurl: setting up for HEAD request');
				$curl->setopt(CURLOPT_NOBODY,1);
			    }
			    else {
				debug_message ('libcurl: setting up for GET request');
				$curl->setopt(CURLOPT_HTTPGET,1);
				$curl->setopt(CURLOPT_FILE, $client);
			    }
			
			    push @cache_control, 'Pragma:' if ! grep /^Pragma:/, @cache_control; # Override libcurl default.
			    $curl->setopt(CURLOPT_HTTPHEADER, \@cache_control);
			    $curl->setopt(CURLOPT_URL, $curl_req);
			    $curl->setopt(CURLOPT_WRITEHEADER, $client);

			    $active_handles++;
			}
			
			while ($active_handles) {
			    my $active_transfers = $curlm->perform;
			    if ($active_transfers != $active_handles) {
				while (my ($id,$return_value) = $curlm->info_read)  {
				    debug_message("curl handle #$id completed, status: $return_value");
				    $active_handles--;
				    my($client_socket,$client_curl)=@{$easy{$id}};
				    print $client_socket "__APT-CACHER_LIBCURL_EOF__\n";
				    print $client_socket freeze ($return_value, $client_curl->errbuf)."\n";
				    $client_socket->shutdown(2); # Done
				    delete $easy{$id};
				    debug_message("libcurl active transfers: $active_transfers");
				}
			    }
			    # Check for pending new request. Use a small select
			    # timeout here which also prevents the parent while
			    # loop from running too fast and hogging the CPU
			    # uselessly.
			    if ($active_handles && $select->can_read(0.00001)) {
				debug_message('Pending connection');
				next LIBCURL_REQUEST;
			    }
			}
		    }
		}
	    }

	    unlink ($cfg->{libcurl_socket});
	    debug_message("Libcurl thread inactive. Exiting");
	    exit(0);
	}
	else {
	    # Parent
	    while (kill 0, $lc_pid){ # Still running
		if ($conn= IO::Socket::UNIX->new($cfg->{libcurl_socket})) {
		    debug_message("Connection to new libcurl process on $cfg->{libcurl_socket}");
		    last;
		}
		else {
		    debug_message('Waiting for libcurl socket');
		    sleep 1;
		}
	    }
	}
    }
    return $conn;
}

sub init_curl {

    debug_message('Init new libcurl object');
    my $curl=new WWW::Curl::Easy;

    # General
    $curl->setopt(CURLOPT_USERAGENT, "apt-cacher/$version ".$curl->version);
    $curl->setopt(CURLOPT_NOPROGRESS, 1);
    $curl->setopt(CURLOPT_CONNECTTIMEOUT, 60);
    $curl->setopt(CURLOPT_LOW_SPEED_LIMIT, 0);
    $curl->setopt(CURLOPT_LOW_SPEED_TIME, $cfg->{fetch_timeout});
    $curl->setopt(CURLOPT_INTERFACE, $cfg->{interface}) if defined $cfg->{interface};
    $curl->setopt(CURLOPT_NOSIGNAL, 1);

    # Callbacks
    $curl->setopt(CURLOPT_DEBUGFUNCTION, \&debug_callback);
    $curl->setopt(CURLOPT_VERBOSE, $cfg->{debug});

    #DNS
    $curl->setopt(CURLOPT_DNS_CACHE_TIMEOUT,-1);

    # Proxy
    $curl->setopt(CURLOPT_PROXY, $cfg->{http_proxy})
      if ($cfg->{use_proxy} && $cfg->{http_proxy});
    $curl->setopt(CURLOPT_PROXYUSERPWD, $cfg->{http_proxy_auth})
      if ($cfg->{use_proxy_auth});
	
    # Rate limit support
    my $maxspeed;
    for ($cfg->{limit}) {
	/^\d+$/ && do { $maxspeed = $_; last; };
	/^(\d+)k$/ && do { $maxspeed = $1 * 1024; last; };
	/^(\d+)m$/ && do { $maxspeed = $1 * 1048576; last; };
	warn "Unrecognised limit: $_. Ignoring.";
    }
    if ($maxspeed) {
	debug_message("Setting bandwidth limit to $maxspeed");
	$curl->setopt(CURLOPT_MAX_RECV_SPEED_LARGE, $maxspeed);
    }

    return \$curl;
}

# runs the get or head operations on the user agent
sub libcurl {
    my ($vhost, $uri, $pkfdref) = @_;

    my $url="http://$vhost$uri";

    my $do_hopping = (exists $pathmap{$vhost});
    my $hostcand;

  RETRY_ACTION:

    # make the virtual hosts real. The list is reduced which is not so smart,
    # but since the fetcher process dies anyway it does not matter.
    if($do_hopping) {
	$hostcand = shift(@{$pathmap{$vhost}});
	debug_message("Candidate: $hostcand");
	$url=($hostcand =~ /^http:/ ? '' : 'http://').$hostcand.$uri;
    }

    debug_message("download agent: getting $url");

   # Send request to libcurl thread and wait for our result
    my $response;
    debug_message("Sending libcurl $url");
    unless (my $libcurl = &connect_curlm) {
	$response=HTTP::Response->new(502);
	$response->protocol('HTTP/1.1');
	$response->message('apt-cacher: failed to connect to libcurl');
	$response->header('Content-Length' => '0'); # Not going to return a body
	info_message('Warning: apt-cacher failed to connect to libcurl');
	&write_header(\$response) if defined $pkfdref;
    }
    else {
	print $libcurl freeze($url,(!defined $pkfdref),@cache_control)."\n";
	my ($curl_status,$curl_errbuf,$buf);
	while (<$libcurl>) {
	    # debug_message("libcurl returned $_");
	    if (s/__APT-CACHER_LIBCURL_EOF__\n$//) { # Match and remove, including newline
		my $status_line = <$libcurl>; # Next line is status
		chomp($status_line);
		debug_message("Found EOF marker and status $status_line");
		($curl_status,$curl_errbuf)=thaw($status_line);
		# Still go on to print $_ as it will contain the file tail for binary files
	    }
	    if (!$response) {
		$buf .= $_; # Append
		if (/^\r\n$/) { # Check for end
		    debug_message("libcurl reading of headers complete");	
		    $response=HTTP::Response->parse($buf);
		    if ($pkfdref && $response->is_success) {
 			# Check space
			my (undef, undef, undef, $freespace) = df($cfg->{'cache_dir'});
			$freespace *= 1024;
			if ($response->header('Content-Length') >=  $freespace) {
			    info_message('ALARM: Insuffient diskspace for Content-Length: '.
					 $response->header('Content-Length').
					 " in cache_dir with $freespace freespace");
 			    $response=HTTP::Response->new(503);
 			    $response->protocol('HTTP/1.1');
 			    $response->message('apt-cacher: Cache Full');
 			    $response->header('Content-Length' => '0'); # Not going to return a body
			    write_header(\$response);
			    undef $pkfdref;
 			}
		    }
		    &write_header(\$response) if (defined $pkfdref && defined $response->content_length);
		}
	    }
	    elsif ($pkfdref) {
		print {$$pkfdref} $_;
		data_feed(\$_);
	    }
	}
	if ($pkfdref && $response && !defined $response->content_length) {
	    # Must be HTTP 1.0 server upstream
	    debug_message("No Content-Length received for $url. You may get better performance using a different upstream server.");
	    # Not required as autoflush is now set
	    # $$pkfdref->flush();
	    $response->content_length(-s $$pkfdref);
	    &write_header(\$response);
	}
	unless ($response) {
	    info_message("Warning: failed to parse headers: $buf") if $buf;
	    $response=HTTP::Response->new(502);
	    $response->protocol('HTTP/1.1');
	    $response->message('apt-cacher: failed to parse headers');
	    $response->header('Content-Length' => '0'); # Not going to return a body
	    &write_header(\$response) if defined $pkfdref;
	}
	if (!defined $curl_status) {
	    $curl_status=1;
	    $curl_errbuf = 'Internal pipe closed prematurely';
	}
	if ($curl_status) { # error
	    $response=HTTP::Response->new(502);
	    $response->protocol('HTTP/1.1');
	    $response->message('apt-cacher: libcurl error: '.$curl_errbuf);
	    $response->header('Content-Length' => '0'); # Not going to return a body
	    info_message("Warning: libcurl failed for $url with ".$curl_errbuf);
	    write_header(\$response) if defined $pkfdref; # Replace with error header
	}
	$response->request($url);
    }
    if($do_hopping) {
	# if okay or the last candidate fails, put it back into the list
	if($response->is_success || ! @{$pathmap{$vhost}} ) {
	    unshift(@{$pathmap{$vhost}}, $hostcand);
	}
	else {
	    if($pkfdref) {
		# truncate cached_file to remove previous HTTP error
		truncate($$pkfdref, 0);
		sysseek($$pkfdref, 0, 0);
	    }
	    undef $response;
	    goto RETRY_ACTION;
	}
    }
    return \$response;
}

sub fetch_store {
    my ($host, $uri, $pkfdref) = @_;

    my $url = "http://$host$uri";
    debug_message("fetcher: try to fetch $url");

    # for checksumming
    &data_init;

    my $response = ${&libcurl($host, $uri, $pkfdref)};	

    debug_message('libcurl returned');

    if ($response->is_success) {
	debug_message("stored $url as $cached_file");

	my $dbref=&db;

	# check for file corruption on non-index files
	if( !&is_index_file($cached_file) &&
	    !check_sum($new_filename, $dbref)) {
	    &set_global_lock(': file corruption report');
	    info_message("ALARM! checksum mismatch on $new_filename");
	    unlink $cached_file, $cached_head;
	    open(MF, ">$cached_head") || die $!;
	    print MF "HTTP/1.1 502 Data corruption\r\n";
	    print MF "Content-Length: 0\r\n";
	    close(MF);
	    unlink $cached_file;
	    &release_global_lock;
	}

	# assuming here that the filesystem really closes the file and writes
	# it out to disk before creating the complete flag file

	debug_message("setting complete flag for $new_filename");
	# Now create the file to show the pickup is complete, also store the original URL there
	open(MF, ">$complete_file") || die $!;
	print MF $response->request;
	close(MF);

	# index file? Get checksums
	if ($cached_file =~ /Packages|Sources|Release$|diff_Index$/) {
	    debug_message("Reading checksums from $cached_file\n");
	    # warning, an attacker could poison the checksum cache easily
	    import_sums($$pkfdref, $dbref);
	}
    }
    elsif(HTTP::Status::is_error($response->code)) {
       	debug_message('Got error '.$response->code." for ".$response->request.". Deleting $cached_file.");
	unlink $cached_file;
    }
    flock ($$pkfdref, LOCK_UN);
    close($$pkfdref) || warn "Close $cached_file failed, $!";
    debug_message('fetcher done');
}

# Check if there has been a usage report generated and display it
sub usage_report {
    my $usage_file = "$cfg->{logdir}/report.html";
    &sendrsp(200, 'OK', 'Content-Type', 'text/html', 'Expires', 0);
    if (!-f $usage_file) {
	print $con <<EOF;

<html>
<title>Apt-cacher traffic report</title><style type="text/css"><!--
a { text-decoration: none; }
a:hover { text-decoration: underline; }
h1 { font-family: arial, helvetica, sans-serif; font-size: 18pt; font-weight: bold;}
h2 { font-family: arial, helvetica, sans-serif; font-size: 14pt; font-weight: bold;}
body, td { font-family: arial, helvetica, sans-serif; font-size: 10pt; }
th { font-family: arial, helvetica, sans-serif; font-size: 11pt; font-weight: bold; }
//--></style>
</head>
<body>
<table border=0 cellpadding=8 cellspacing=1 bgcolor="#000000" align="center" width="600">
<tr bgcolor="#9999cc"><td> <h1>Apt-cacher traffic report</h1> </td></tr>
</td></tr>
</table>

<p><table border=0 cellpadding=3 cellspacing=1 bgcolor="#000000" align="center" width="600">
<tr bgcolor="#9999cc"><th bgcolor="#9999cc"> An Apt-cacher usage report has not yet been generated </th></tr>
<tr bgcolor="#cccccc"><td bgcolor="#ccccff"> Reports are generated every 24 hours. If you want reports to be generated, make sure you set '<b>generate_reports=1</b>' in <b>$configfile</b>.</td></tr>
</table>
		</body>
		</html>
EOF

    }
    else
      {
	  open(my $usefile, $usage_file) || die $!;
	  my @usedata = <$usefile>;
	  close($usefile);
	  print $con @usedata;
      }
}

# IP address filtering.
sub ipv4_addr_in_list ($$) {
      return(0) if $_[0] eq '';
      debug_message ("testing $_[1]");
      return(0) unless $cfg->{$_[1]};

      my ($client, $cfitem) = @_;
      my @allowed_hosts = split(/\s*[;,]\s*/, $cfg->{$cfitem});
      for my $ahp (@allowed_hosts)
	{
	    goto unknown if $ahp !~ /^[-\/,.[:digit:]]+$/;

	    # single host
	    if ($ahp =~ /^([^-\/]*)$/)
	      {
		  my $ip = $1;
		  debug_message("checking against $ip");
		  defined ($ip = ipv4_normalise($ip)) or goto unknown;
		  return(1) if $ip eq $client;
	      }
	    # range of hosts (netmask)
	    elsif ($ahp =~ /^([^-\/]*)\/([^-\/]*)$/)
	      {
		  my ($base, $mask) = ($1, $2);
		  debug_message("checking against $ahp");
		  defined ($base = ipv4_normalise($base)) or goto unknown;
		  $mask = ($mask =~ /^\d+$/) ? make_mask ($mask, 32)
		    : ipv4_normalise ($mask);
		  goto unknown unless defined $mask;
		  return(1) if ($client & $mask) eq ($base & $mask);
	      }
	    # range of hosts (start & end)
	    elsif ($ahp =~ /^([^-\/]*)-([^-\/]*)$/)
	      {
		  my ($start, $end) = ($1, $2);
		  debug_message("checking against $start to $end");
		  defined ($start = ipv4_normalise($start)) or goto unknown;
		  defined ($end = ipv4_normalise($end)) or goto unknown;
		  return(1) if $client ge $start && $client le $end;
	      }
	    # unknown
	    else
	      {
		unknown:
		  debug_message("Alert: $cfitem ($ahp) is bad");
		  &sendrsp(500, 'Configuration error');
		  exit(4);
	      }
	}
      return(0); # failed
}

sub ipv6_addr_in_list ($$) {
    return(0) if $_[0] eq '';
    debug_message ("testing $_[1]");
    return(0) unless $cfg->{$_[1]};

    my ($client, $cfitem) = @_;
    my @allowed_hosts = split(/\s*[;,]\s*/, $cfg->{$cfitem});
    for my $ahp (@allowed_hosts)
      {
	  goto unknown if $ahp !~ /^[-\/,:[:xdigit:]]+$/;

	  # single host
	  if ($ahp =~ /^([^-\/]*)$/)
	    {
		my $ip = $1;
		debug_message("checking against $ip");
		$ip = ipv6_normalise($ip);
		goto unknown if $ip eq '';
		return(1) if $ip eq $client;
	    }
	  # range of hosts (netmask)
	  elsif ($ahp =~ /^([^-\/]*)\/([^-\/]*)$/)
	    {
		my ($base, $mask) = ($1, $2);
		debug_message("checking against $ahp");
		$base = ipv6_normalise($base);
		goto unknown if $base eq '';
		goto unknown if $mask !~ /^\d+$/ || $mask < 0 || $mask > 128;
		my $m = ("\xFF" x ($mask / 8));
		$m .= chr ((-1 << (8 - $mask % 8)) & 255) if $mask % 8;
		$mask = $m . ("\0" x (16 - length ($m)));
		return(1) if ($client & $mask) eq ($base & $mask);
	    }
	  # range of hosts (start & end)
	  elsif ($ahp =~ /^([^-\/]*)-([^-\/]*)$/)
	    {
		my ($start, $end) = ($1, $2);
		debug_message("checking against $start to $end");
		$start = ipv6_normalise($start);
		$end = ipv6_normalise($end);
		goto unknown if $start eq '' || $end eq '';
		return(1) if $client ge $start && $client le $end;
	    }
	  # unknown
	  else
	    {
	      unknown:
		debug_message("Alert: $cfitem ($ahp) is bad");
		&sendrsp(500, 'Configuration error');
		exit(4);
	    }
      }
    return(0); # failed
}

sub sendrsp {
    my $code=shift;
    my $msg=shift;
    $msg='' if !defined($msg);

    my $initmsg=
    ($mode && $mode eq 'cgi') ?
    "Status: $code $msg\r\n" :
    "HTTP/1.1 $code $msg\r\n";

    $initmsg.="Connection: Keep-Alive\r\nAccept-Ranges: bytes\r\nKeep-Alive: timeout=15, max=100\r\n" if ($code != 403);

    #debug_message("Sending Response: $initmsg");
    print $con $initmsg;

    my $altbit=0;
    for(@_) {
	$altbit=!$altbit;
	if($altbit) {
	    #debug_message("$_: ");
	    print $con "$_: ";
	}
	else {
	    #debug_message("$_\r\n");
	    print $con "$_\r\n";
	}
    }
    print $con "\r\n";
}

# DOS attack safe input reader
my @reqLineBuf;
my $reqTail;
sub getRequestLine {
    # if executed through a CGI wrapper setting a flag variable
    if($ENV{CGI_MODE})
      {
	  my $cgi_path;
	  # pick up the URL
	  $cgi_path=$ENV{PATH_INFO} if ! $cgi_path;
	  $cgi_path=$ENV{QUERY_STRING} if ! $cgi_path;
	  $cgi_path='/' if ! $cgi_path; # set an invalid path to display infos below

	  push(@reqLineBuf, "GET $cgi_path", '', undef); # undef stops operation
	  undef $cgi_path; # don't re-add it
    }
    while(!@reqLineBuf) {
	# Fill buffer
	if (my $ret=sysread($source, my $buf, 1024)) {

	    $buf=$reqTail.$buf if(defined($reqTail));
	    undef $reqTail;

	    # Split line and push into array.  The last one may be incomplete,
	    push(@reqLineBuf, split(/\r\n/, $buf, -1));

	    # Last line is incomplete. Save for next iteration
	    # Also works if \r and \n are separated
	    if(substr($buf, -2) ne "\r\n") {
		$reqTail=pop(@reqLineBuf);
	    }
	    else {
		pop(@reqLineBuf);
	    }
	}
	else {
	    info_message "Warning: Read failed: $!" if !defined $ret && $source->error;
	    last;
	}
    }
    return shift(@reqLineBuf);
}

sub get_inetd_port {
    # Does not handle multiple entries
    # I don't know how to find which one would be correct
    my $inetdconf = '/etc/inetd.conf';
    my $xinetdconf = '/etc/xinetd.conf';
    my $xinetdconfdir = '/etc/xinetd.d';
    my $port;

    if (-f $inetdconf && -f '/var/run/inetd.pid') {
	open(FILE, $inetdconf) || do {
	    info_message("Warning: Cannot open $inetdconf, $!");
	    return;
	    };
	while (<FILE>) {
	    next if /^(?:#|$)/; # Weed comments and empty lines
	    if (/^\s*(\S+)\s+.*apt-cacher/) {
		$port = $1;
		last;
	    }
	}
	close (FILE);
	info_message("Warning: no apt-cacher port found in $inetdconf") if !$port;
    }
    elsif ( -f '/var/run/xinetd.pid' && -f $xinetdconfdir || -f $xinetdconf ) {
	my $ident;
	my $found;
      FILE:
	for ($xinetdconf, <$xinetdconfdir/*>) {
	    open(FILE, $_) || do {
		info_message("Warning: Cannot open $_, $!"); next;
	    };
	  LINE:
	    while (<FILE>) {
		next LINE if /^(?:#|$)/; # Weed comments and empty lines
		if (/^\s*service\s+(\S+)/) {
		    $ident = $1;
		    next LINE;
		}
		$found += /^\s+server(?:_args)?\s*=.*apt-cacher/;
		if (/^\s+port\s*=\s*(\d+)/) {
		    $ident = $1;
		}
	    }
	    close (FILE);
	    if ($found) {
		$port = $ident;
		debug_message("Found inetd port match $port");
		last FILE;
	    }
	}
	info_message("Warning: no apt-cacher port found in $xinetdconf") if !$found;
    }
    else {
	info_message('Warning: no running inetd server found');
    }
    return $port;
}

sub io_socket_inet46 {
    # Test if IPv6 is available and use if it is
    if (eval{local $SIG{__DIE__} = 'IGNORE'; # Prevent log verbosity
	     require IO::Socket::INET6}){
	import IO::Socket::INET6;
	debug_message('Using IPv6');
	return  IO::Socket::INET6->new(@_);
    }
    else {
	return IO::Socket::INET->new(@_);
    }
}

# BEGIN MAIN PART

# Read config and command line, setup variables
&setup;

# Output data as soon as we print it
$| = 1;

#Signal Handlers
$SIG{CHLD} = 'IGNORE';
$SIG{TERM} = sub {debug_message('received SIGTERM, terminating'); exit};
$SIG{HUP} = \&reload_config;
$SIG{USR1} = \&toggle_debug;
$SIG{PIPE} = sub {debug_message "Got SIGPIPE!"; exit};
END {
    &clean_exit;
}


if($mode && $mode eq 'cgi' && defined($cfg->{cgi_advise_to_use}) && $cfg->{cgi_advise_to_use}) {
    print "Status: 410 $cfg->{cgi_advise_to_use}\r\n\r\n";
    exit(0);
}

if($mode) {
    open (STDERR, '>/dev/null') || die $!;
    &setup_ownership;
    &open_log_files;
    $0="$0 [$mode]"; # Visible to ps and friends
    &handle_connection;
    exit(0);
}

$listeners=IO::Select->new;
for my $daemon_addr ($cfg->{daemon_addr} ?
		     (grep !/^\s*$/, # Weed empty or just whitespace
		      (split /\s*[,;]\s*/, $cfg->{daemon_addr})) :
		     undef # ensure run once
		    ) {
    my $socket;
    my %daemonopts = (LocalPort => $cfg->{daemon_port},
		      Proto => 'tcp',
		      Listen => 1,
		      ReuseAddr => 1);
    $daemonopts{LocalAddr}=$daemon_addr if(defined($daemon_addr));

    my $retnum = $cfg->{retry};
    while(1) {
	$socket = io_socket_inet46(%daemonopts);
	last if $socket;
	$retnum--;
	last if($retnum<=0);
	print STDERR "Unable to bind socket ("
	  .($daemon_addr ? "$daemon_addr " : '')
	    ."port $cfg->{daemon_port}), trying again in 5 seconds.\n";
	sleep 5;
    }
    die "Unable to bind socket ("
      .($daemon_addr ? "$daemon_addr " : '')
	."port $cfg->{daemon_port}), $0 not started.\n" if ! $socket;
    $listeners->add($socket);
    debug_message("Listening on ". $socket->sockhost . ':' . $socket->sockport)
}

if ($cfg->{fork}) {
    debug_message 'fork listener';
    my $pid = fork();
    if ($pid <0) {
	barf('fork() failed');
    }
    if ($pid > 0) {
	# parent
	undef $listeners;
	exit;
    }
    # child
    {
	no warnings 'io'; # Silence the reopen warning
	close (STDIN);
	open (STDOUT, '>/dev/null') || die $!;
	open (STDERR, '>/dev/null') || die $!;
    }
}

# This is the controlling process
if($cfg->{pidfile}) {
    open(my $fh, ">$cfg->{pidfile}") || die "Unable to open $cfg->{pidfile}, $!";
    print $fh $$;
    close($fh);
}
&setup_ownership;
&open_log_files;

# State: READY
# That is the working condition (daemon mode)

debug_message("Apt-Cacher version $version started with Debug output enabled");

while (1) {
    foreach ($listeners->can_read) {
	my $newcon = $_->accept;
	# we don't stop, only by term_handler since the accept method is unreliable
	next if(!$newcon);
	last if $terminating;

	debug_message('Connection from '.$newcon->peerhost);

	my $pid = fork();
	if ($pid < 0) {
	    barf('fork() failed');
	}

	if ($pid > 0) {
	    # parent
	    debug_message("registered child process: $pid");
	    push @childPids, $pid;
	    next;
	}
	# child
	undef @childPids;
	undef $listeners;

	&handle_connection($newcon);
	exit(0);

    }
}
exit(0);
