urpmi-proxy/trunk/urpmi-proxy.cgi

#!/usr/bin/perl -w
## written by Maarten Vanraes (c) 2009-2011
## urpmi-proxy is GPLv2+

use strict;
use warnings;

my $debug = 0;
my $config_file = '/etc/urpmi-proxy.conf';

# config defaults
my $cache_tmp_path = '/var/tmp/urpmi-proxy';
my $cache_path = '/var/cache/urpmi-proxy';
my $logfile = '/var/log/urpmi-proxy.log';
my $check_updates_only_files = 'MD5SUM';
my $check_no_updates_files;
my $merge_files = 'media.cfg';
my $sources = [
        'urpmi'
];
my $connect_timeout = 120;
my $ftp_response_timeout = 30;
my $max_stall_speed = 8192;
my $max_stall_time = 60;

# load config file
if (-R $config_file) {
        my $r = open(FILE, '<', $config_file);
        if ($r) {
                my $l = '';
                while (<FILE>) {
                        $l .= $_;
                }
                eval $l;
                close FILE;
        }
}
print STDERR "logfile: $logfile\n" if $debug;

my $sou;
print STDERR "orig sources: " . scalar(@$sources) . "\n" if $debug;
if ($debug) {
        foreach $sou (@$sources) {
                print STDERR " - " . $sou . "\n";
        }
}

# prepare cache path
system("mkdir -p $cache_tmp_path");

# check for valid request
my $file = $ENV{PATH_INFO};
return_error(500, 'Server error') if !$file;

# split up request
return_error(500, 'Server error') if $file !~ m!^(.+)/([^/]*)$!;
my $dest_path = $1;
my $filename = $2;
my $file_type = "";
my $merge = 0;

print STDERR "file: $file\n" if $debug;
print STDERR "dest_path: $dest_path\n" if $debug;
print STDERR "filename: $filename\n" if $debug;

# check if request needs update checking
my $check_file = 1;
$check_file = 0 if defined $check_no_updates_files && $filename =~ m/$check_no_updates_files/;
if (defined $check_updates_only_files) {
        $check_file = 0;
        $check_file = 1 if $filename =~ m/$check_updates_only_files/;
}

# check if request needs merging
$merge = 1 if $filename =~ m/$merge_files/;
$check_file = 1 if $merge;

print STDERR "check_file: $check_file\n" if $debug;
print STDERR "merge: $merge\n" if $debug;

# if the file needs no update checks, check in cache
return_file($cache_path, $file, $logfile, 'CACHED_NO_CHECK') if (!$check_file && $filename && -R $cache_path . $file);

# get datetime from local file if it exists
my $timestamp = 0;
if ($filename && !$check_file && -R $cache_path . $file) {
        my @sv = lstat($cache_path . $file);
        $timestamp = $sv[9];
        print STDERR "timestamp: $timestamp\n" if $debug;
}

# set up curl with timecheck
my $curl;
my $r = 0;
my $file_sent = 0;
#my $file_deleted = 0;
my $file_unmodified = 0;
my $file_time = -1;
my $err = 200;

# prepare curl transfer
my $tmp_file = $cache_tmp_path . "/" . rand() . $$;
open(FILEHANDLE, ">", $tmp_file) or do {
        _log($logfile, $file, 500, 'MISS');
        return_error(500, 'Server error');
};
binmode(FILEHANDLE);
my %curldata = (fh => \*FILEHANDLE, file_sent => \$file_sent, content_type => $file_type, size => -1, merge => \$merge);

print STDERR "sources: " . scalar(@$sources) . "\n" if $debug;
if ($debug) {
        foreach $sou (@$sources) {
                print STDERR " - " . $sou . "\n";
        }
}

# filter out duplicate sources (and expand urpmi)
my @sources;
my %seen;
foreach my $s (@$sources) {
        # heh
        next if $seen{$s}++;
        if ($s eq "urpmi") {
                # urpmi support is required
                use urpm;
                use urpm::cfg;
                my $urpm = new urpm();
                urpm::get_global_options($urpm);
                my $config = urpm::cfg::load_config($urpm->{config});
                my %s;
                foreach my $media (@{$config->{media}}) {
                        if (!$media->{ignore}) {
                                if ($media->{mirrorlist} && !($seen{'mirrorlist:' . $media->{mirrorlist}}++)) {
                                        # push mirrorlists now so they'll be first
                                        push @sources, 'mirrorlist://' . $media->{mirrorlist};
                                }
                                elsif ($media->{url} && !($seen{$media->{url}}++)) {
                                        $s{$media->{url}} = 1;
                                }
                        }
                }
                # push the urls
                push @sources, keys %s if scalar(keys %s);
        }
        else {
                push @sources, $s;
        }
}

# check for source
print STDERR "interpolated sources: " . scalar(@sources) . "\n" if $debug;
if ($debug) {
        foreach $sou (@sources) {
                print STDERR " - " . $sou . "\n";
        }
}
foreach my $source (@sources) {
        my ($type, @loc) = split('://', $source);
        my $loc = join('://', @loc);
        print STDERR "source of type $type: '" . $source . "'\n" if $debug;
        if ($type eq 'mirrorlist') {
                # get exact url from cache and parse
                my $res = open(FILE, '<', '/var/cache/urpmi/mirrors.cache');
                if ($res) {
                        my $mirrorcache = '';
                        while (<FILE>) {
                                $mirrorcache .= $_;
                        }
                        close FILE;
                        my $host_loc = $loc;
                        $host_loc =~ s/\$/\\\$/g;
                        if ($mirrorcache =~ m/'$host_loc'\s+=>\s+{[\r\n]+\s+'chosen'\s+=>\s+'([^']+)'/m) {
                                $source = $1;
                                # rectify source to remove '/distrib/version/arch'
                                $source =~ s!/[^/]+/[^/]+/[^/]+$!!;
                                print STDERR "mirrorlist returns source '$source'\n" if $debug;
                                ($type, @loc) = split('://', $source);
                                $loc = join('://', @loc);
                                if (defined $type) {
                                        print STDERR "mirrorlist returns type $type: '" . $source . "'\n" if $debug;
                                }
                                else {
                                        print STDERR "transfer error: mirrorlist is no url '" . $source . "'.\n" if $debug;
                                        $type = '';
                                }
                        }
                        else {
                                print STDERR "transfer error: mirrorlist has no chosen url '" . $source . "'.\n" if $debug;
                                $type = '';
                        }
                }
                else {
                        print STDERR "transfer error: couldn't open mirrorlist cache.\n" if $debug;
                }
        }
        if ($type eq 'rsync') {
                # find the equivalent ftp mirror location by hostname
                my $res = open(FILE, '<', '/var/cache/urpmi/mirrors.cache');
                if ($res) {
                        my $mirrorcache = '';
                        while (<FILE>) {
                                $mirrorcache .= $_;
                        }
                        close FILE;
                        my $loc_host = $loc;
                        $loc_host =~ s!/.+!!;
                        if ($mirrorcache =~ m!'url'\s+=>\s+'((ftp|http)://$loc_host/[^']+)'!) {
                                $source = $1;
                                # rectify source to remove '/distrib/version/arch'
                                $source =~ s!/[^/]+/[^/]+/[^/]+$!!;
                                print STDERR "rsync switch returns source '$source'\n" if $debug;
                                ($type, @loc) = split('://', $source);
                                $loc = join('://', @loc);
                                if (defined $type) {
                                        print STDERR "rsync switch returns type $type: '" . $source . "'\n" if $debug;
                                }
                                else {
                                        print STDERR "transfer error: rsync switch is no url '" . $source . "'.\n" if $debug;
                                        $type = '';
                                }
                        }
                        else {
                                print STDERR "transfer error: rsync switch has no suitable url '" . $source . "'.\n" if $debug;
                                $type = '';
                        }
                }
                else {
                        print STDERR "transfer error: couldn't open mirrorlist cache.\n" if $debug;
                }
        }
        if ($type eq 'file') {
                if ($filename && -R $loc . $file) {
                        my $ft = `file -b --mime-type $loc$file`;
                        $ft =~ s/[\s\r\n]*$//;
                        print STDERR "mimetype: '$ft'\n" if $debug;
                        print STDERR "size: " . (-s $loc . $file) . "\n" if $debug;
                        $r = open(FILE, "<", $loc . $file);
                        if ($r) {
                                print STDERR "file fetch url '" . $loc . $file . "'\n" if $debug;
                                if (!$file_sent) {
                                        $file_sent = 1;
                                        print "Content-Type: " . $ft . "\r\n";
                                        print "Content-Length: " . (-s $loc . $file) . "\r\n" if !$merge;
                                        print "\r\n";
                                }
                                binmode(FILE);
                                my $buf;
                                while (read(FILE, $buf, 1024)) {
                                        print FILEHANDLE $buf;
                                        print $buf;
                                }
                                close FILE;
                                $r = 0;
                        }
                        else {
                                print STDERR "transfer error: couldn't open file '" . $loc . $file . "'.\n" if $debug;
                                $r = 1;
                                $err = 404;
                        }
                }
                else {
                        print STDERR "transfer error: couldn't read file '" . $loc . $file . "'.\n" if $debug;
                }
        }
        elsif ($type) {
                if (!defined $curl) {
                        use WWW::Curl::Easy;
                        # set up curl stuff
                        $curl = new WWW::Curl::Easy;
                        if ($timestamp > 0) {
                                $curl->setopt(CURLOPT_TIMECONDITION, 1); # CURL_TIMECOND_IFMODSINCE
                                $curl->setopt(CURLOPT_TIMEVALUE, $timestamp);
                        }
                        $curl->setopt(CURLOPT_CONNECTTIMEOUT, $connect_timeout);
                        $curl->setopt(CURLOPT_FTP_RESPONSE_TIMEOUT, $ftp_response_timeout);
                        $curl->setopt(CURLOPT_LOW_SPEED_LIMIT, $max_stall_speed);
                        $curl->setopt(CURLOPT_LOW_SPEED_TIME, $max_stall_time);
                        $curl->setopt(CURLOPT_FOLLOWLOCATION, 1);
                        $curl->setopt(CURLOPT_FILETIME, 1);
                        # hook curl transfer functions for local caching
                        $curl->setopt(CURLOPT_WRITEDATA, \%curldata);
                        $curl->setopt(CURLOPT_WRITEFUNCTION, \&write_function);
                        $curl->setopt(CURLOPT_WRITEHEADER, \%curldata);
                        $curl->setopt(CURLOPT_HEADERFUNCTION, \&header_function);
                }
                # depending on type check if remote file is newer
                print STDERR "curl fetch url '" . $source . $file . "'\n" if $debug;
                $curl->setopt(CURLOPT_URL, $source . $file);
                $r = $curl->perform;
                print STDERR "curl return value: " . $err . "\n" if $debug;
                # use curl to get it and output it directly
                if ($r == 0) {
                        $err = $curl->getinfo(CURLINFO_HTTP_CODE);
                        if ($err =~ m/^2/ || $err == 304) {
                                if ($curl->getinfo(CURLINFO_CONDITION_UNMET)) {
                                        $file_unmodified = 1;
                                }
                                $file_time = $curl->getinfo(CURLINFO_FILETIME);
                        }
                        else {
                                # error stuff ?
                                print STDERR "transfer error: http code " . $err . "\n" if $debug;
                        }
                }
                else {
                        # error stuff ?
                        print STDERR "transfer error: " . $curl->strerror($r) . " ($r)\n" if $debug;
                }
        }
        else {
                print STDERR "transfer error: this source does not have a type\n" if $debug;
        }
        last if $file_sent && !$merge;
}

my $extra = '';

close(FILEHANDLE);

if ($file_sent && $r == 0 && $err =~ m/^2/ && $filename) {
        # clean up file and move to correct location
        if (system("mkdir -p $cache_path$dest_path") == 0) {
                if (rename($tmp_file, $cache_path . $file)) {
                        utime(time(), $file_time, $cache_path . $file) if $file_time > 0;
                }
                else {
                        print STDERR "WARNING: file '$tmp_file' could not be moved to '$cache_path$file'\n";
                }
        }
        else {
                print STDERR "WARNING: containing path for '$cache_path$file' could not be created\n";
        }
        _log($logfile, $file, 200, 'MISS');
}
else {
        unlink($tmp_file);
        if ($file_sent) {
                if ($filename) {
                        _log($logfile, $file, $err, 'MISS_FAIL_SENT');
                }
                else {
                        # It was actually successful, but paths can't be saved...
                        print STDERR "NOTICE: paths cant be saved: '$file'\n" if $debug;
                        _log($logfile, $file, $err, 'MISS');
                }
                exit 0;
        }
        $extra = '_UNMODIFIED' if $file_unmodified;
        return_file($cache_path, $file, $logfile, 'HIT_AFTER_FAIL' . $extra) if $filename && -R $cache_path . $file;
        _log($logfile, $file, 404, 'MISS_FAIL');
        return_error(404, 'File not found');
}

print STDERR "finished." if $debug;

exit 0;

sub header_function {
        my ($ptr, $data) = @_;
        if (!${$data->{file_sent}}) {
                $data->{http_header} = $1 if $ptr =~ m!^HTTP/[0-9.]+\s+(.+?)[\s\r\n]*$!;
                $data->{content_type} = $1 if $ptr =~ m/^Content-[tT]ype:\s+(.+?)[\s\r\n]*$/;
                $data->{size} = $1 if $ptr =~ m/^Content-[lL]ength:\s+(.+?)[\s\r\n]*$/;
                $data->{size} = $1 if $ptr =~ m/^213\s+(.+?)[\s\r\n]*$/;
        }
        return length($ptr);
}

sub write_function {
        my ($ptr, $data) = @_;
        my $f = ${$data->{fh}};
        print $f ($ptr);
        if (!${$data->{file_sent}}) {
                ${$data->{file_sent}} = 1;
                print STDERR "HTTP header: " . $data->{http_header} . "\n" if $debug && defined $data->{http_header};
                print STDERR "Content-Type: " . $data->{content_type} . "\n" if $debug && defined $data->{content_type};
                print STDERR "Content-Length: " . $data->{size} . "\n" if $debug;
                print "Status: " . $data->{http_header} . "\r\n" if $data->{http_header} && $data->{http_header} !~ m/^2/;
                print "Content-Type: " . $data->{content_type} . "\r\n" if $data->{content_type};
                print "Content-Length: " . $data->{size} . "\r\n" if $data->{size} > -1 && !${$data->{merge}};
                print "\r\n";
        }
        print $ptr;
        return length($ptr);
}

sub _log {
        my ($logfile, $file, $code, $cached) = @_;
        my $date = `date`;
        $date =~ s/[\s\r\n]*$//;
        open(FILE, ">>" . $logfile) or return;
        print FILE "[" . $date . "] $file - $code - $cached\n";
        close(FILE);
}

sub return_file {
        my ($cache_path, $file, $logfile, $cached)=@_;
        open(FILE, "<", $cache_path . $file) or do {
                _log($logfile, $file, 500, $cached);
                return_error(500, 'Server error');
        };
        my $ft = `file -b --mime-type $cache_path$file`;
        $ft =~ s/[\s\r\n]*$//;
        print STDERR "mimetype: '$ft'\n" if $debug;
        print STDERR "size: " . (-s $cache_path . $file) . "\n" if $debug;
        print "Content-Type: " . $ft . "\r\n";
        print "Content-Length: " . (-s $cache_path . $file) . "\r\n\r\n";
        binmode(FILE);
        my $buf;
        while (read(FILE, $buf, 1024)) {
                print $buf;
        }
        close FILE;
        _log($logfile, $file, 200, $cached);
        exit 0;
}

sub return_error {
        my ($code, $text) = @_;
        print "Status: $code $text\r\n\r\n";
        print STDERR "$code $text.\n" if $debug;
        exit 0;
}
1	alien	3078	#!/usr/bin/perl -w
2			## written by Maarten Vanraes (c) 2009-2011
3			## urpmi-proxy is GPLv2+
4
5			use strict;
6			use warnings;
7
8			my $debug = 0;
9			my $config_file = '/etc/urpmi-proxy.conf';
10
11			# config defaults
12			my $cache_tmp_path = '/var/tmp/urpmi-proxy';
13			my $cache_path = '/var/cache/urpmi-proxy';
14			my $logfile = '/var/log/urpmi-proxy.log';
15			my $check_updates_only_files = 'MD5SUM';
16			my $check_no_updates_files;
17			my $merge_files = 'media.cfg';
18			my $sources = [
19			'urpmi'
20			];
21			my $connect_timeout = 120;
22			my $ftp_response_timeout = 30;
23			my $max_stall_speed = 8192;
24			my $max_stall_time = 60;
25
26			# load config file
27			if (-R $config_file) {
28			my $r = open(FILE, '<', $config_file);
29			if ($r) {
30			my $l = '';
31			while (<FILE>) {
32			$l .= $_;
33			}
34			eval $l;
35			close FILE;
36			}
37			}
38			print STDERR "logfile: $logfile\n" if $debug;
39
40			my $sou;
41			print STDERR "orig sources: " . scalar(@$sources) . "\n" if $debug;
42			if ($debug) {
43			foreach $sou (@$sources) {
44			print STDERR " - " . $sou . "\n";
45			}
46			}
47
48			# prepare cache path
49			system("mkdir -p $cache_tmp_path");
50
51			# check for valid request
52			my $file = $ENV{PATH_INFO};
53			return_error(500, 'Server error') if !$file;
54
55			# split up request
56			return_error(500, 'Server error') if $file !~ m!^(.+)/([^/]*)$!;
57			my $dest_path = $1;
58			my $filename = $2;
59			my $file_type = "";
60			my $merge = 0;
61
62			print STDERR "file: $file\n" if $debug;
63			print STDERR "dest_path: $dest_path\n" if $debug;
64			print STDERR "filename: $filename\n" if $debug;
65
66			# check if request needs update checking
67			my $check_file = 1;
68			$check_file = 0 if defined $check_no_updates_files && $filename =~ m/$check_no_updates_files/;
69			if (defined $check_updates_only_files) {
70			$check_file = 0;
71			$check_file = 1 if $filename =~ m/$check_updates_only_files/;
72			}
73
74			# check if request needs merging
75			$merge = 1 if $filename =~ m/$merge_files/;
76			$check_file = 1 if $merge;
77
78			print STDERR "check_file: $check_file\n" if $debug;
79			print STDERR "merge: $merge\n" if $debug;
80
81			# if the file needs no update checks, check in cache
82			return_file($cache_path, $file, $logfile, 'CACHED_NO_CHECK') if (!$check_file && $filename && -R $cache_path . $file);
83
84			# get datetime from local file if it exists
85			my $timestamp = 0;
86			if ($filename && !$check_file && -R $cache_path . $file) {
87			my @sv = lstat($cache_path . $file);
88			$timestamp = $sv[9];
89			print STDERR "timestamp: $timestamp\n" if $debug;
90			}
91
92			# set up curl with timecheck
93			my $curl;
94			my $r = 0;
95			my $file_sent = 0;
96			#my $file_deleted = 0;
97			my $file_unmodified = 0;
98			my $file_time = -1;
99			my $err = 200;
100
101			# prepare curl transfer
102			my $tmp_file = $cache_tmp_path . "/" . rand() . $$;
103			open(FILEHANDLE, ">", $tmp_file) or do {
104			_log($logfile, $file, 500, 'MISS');
105			return_error(500, 'Server error');
106			};
107			binmode(FILEHANDLE);
108			my %curldata = (fh => \*FILEHANDLE, file_sent => \$file_sent, content_type => $file_type, size => -1, merge => \$merge);
109
110			print STDERR "sources: " . scalar(@$sources) . "\n" if $debug;
111			if ($debug) {
112			foreach $sou (@$sources) {
113			print STDERR " - " . $sou . "\n";
114			}
115			}
116
117			# filter out duplicate sources (and expand urpmi)
118			my @sources;
119			my %seen;
120			foreach my $s (@$sources) {
121			# heh
122			next if $seen{$s}++;
123			if ($s eq "urpmi") {
124			# urpmi support is required
125			use urpm;
126			use urpm::cfg;
127			my $urpm = new urpm();
128			urpm::get_global_options($urpm);
129			my $config = urpm::cfg::load_config($urpm->{config});
130			my %s;
131			foreach my $media (@{$config->{media}}) {
132			if (!$media->{ignore}) {
133			if ($media->{mirrorlist} && !($seen{'mirrorlist:' . $media->{mirrorlist}}++)) {
134			# push mirrorlists now so they'll be first
135			push @sources, 'mirrorlist://' . $media->{mirrorlist};
136			}
137			elsif ($media->{url} && !($seen{$media->{url}}++)) {
138			$s{$media->{url}} = 1;
139			}
140			}
141			}
142			# push the urls
143			push @sources, keys %s if scalar(keys %s);
144			}
145			else {
146			push @sources, $s;
147			}
148			}
149
150			# check for source
151			print STDERR "interpolated sources: " . scalar(@sources) . "\n" if $debug;
152			if ($debug) {
153			foreach $sou (@sources) {
154			print STDERR " - " . $sou . "\n";
155			}
156			}
157			foreach my $source (@sources) {
158			my ($type, @loc) = split('://', $source);
159			my $loc = join('://', @loc);
160			print STDERR "source of type $type: '" . $source . "'\n" if $debug;
161			if ($type eq 'mirrorlist') {
162			# get exact url from cache and parse
163			my $res = open(FILE, '<', '/var/cache/urpmi/mirrors.cache');
164			if ($res) {
165			my $mirrorcache = '';
166			while (<FILE>) {
167			$mirrorcache .= $_;
168			}
169			close FILE;
170			my $host_loc = $loc;
171			$host_loc =~ s/\$/\\\$/g;
172			if ($mirrorcache =~ m/'$host_loc'\s+=>\s+{[\r\n]+\s+'chosen'\s+=>\s+'([^']+)'/m) {
173			$source = $1;
174			# rectify source to remove '/distrib/version/arch'
175			$source =~ s!/[^/]+/[^/]+/[^/]+$!!;
176			print STDERR "mirrorlist returns source '$source'\n" if $debug;
177			($type, @loc) = split('://', $source);
178			$loc = join('://', @loc);
179			if (defined $type) {
180			print STDERR "mirrorlist returns type $type: '" . $source . "'\n" if $debug;
181			}
182			else {
183			print STDERR "transfer error: mirrorlist is no url '" . $source . "'.\n" if $debug;
184			$type = '';
185			}
186			}
187			else {
188			print STDERR "transfer error: mirrorlist has no chosen url '" . $source . "'.\n" if $debug;
189			$type = '';
190			}
191			}
192			else {
193			print STDERR "transfer error: couldn't open mirrorlist cache.\n" if $debug;
194			}
195			}
196			if ($type eq 'rsync') {
197			# find the equivalent ftp mirror location by hostname
198			my $res = open(FILE, '<', '/var/cache/urpmi/mirrors.cache');
199			if ($res) {
200			my $mirrorcache = '';
201			while (<FILE>) {
202			$mirrorcache .= $_;
203			}
204			close FILE;
205			my $loc_host = $loc;
206			$loc_host =~ s!/.+!!;
207			if ($mirrorcache =~ m!'url'\s+=>\s+'((ftp\|http)://$loc_host/[^']+)'!) {
208			$source = $1;
209			# rectify source to remove '/distrib/version/arch'
210			$source =~ s!/[^/]+/[^/]+/[^/]+$!!;
211			print STDERR "rsync switch returns source '$source'\n" if $debug;
212			($type, @loc) = split('://', $source);
213			$loc = join('://', @loc);
214			if (defined $type) {
215			print STDERR "rsync switch returns type $type: '" . $source . "'\n" if $debug;
216			}
217			else {
218			print STDERR "transfer error: rsync switch is no url '" . $source . "'.\n" if $debug;
219			$type = '';
220			}
221			}
222			else {
223			print STDERR "transfer error: rsync switch has no suitable url '" . $source . "'.\n" if $debug;
224			$type = '';
225			}
226			}
227			else {
228			print STDERR "transfer error: couldn't open mirrorlist cache.\n" if $debug;
229			}
230			}
231			if ($type eq 'file') {
232			if ($filename && -R $loc . $file) {
233			my $ft = `file -b --mime-type $loc$file`;
234			$ft =~ s/[\s\r\n]*$//;
235			print STDERR "mimetype: '$ft'\n" if $debug;
236			print STDERR "size: " . (-s $loc . $file) . "\n" if $debug;
237			$r = open(FILE, "<", $loc . $file);
238			if ($r) {
239			print STDERR "file fetch url '" . $loc . $file . "'\n" if $debug;
240			if (!$file_sent) {
241			$file_sent = 1;
242			print "Content-Type: " . $ft . "\r\n";
243			print "Content-Length: " . (-s $loc . $file) . "\r\n" if !$merge;
244			print "\r\n";
245			}
246			binmode(FILE);
247			my $buf;
248			while (read(FILE, $buf, 1024)) {
249			print FILEHANDLE $buf;
250			print $buf;
251			}
252			close FILE;
253			$r = 0;
254			}
255			else {
256			print STDERR "transfer error: couldn't open file '" . $loc . $file . "'.\n" if $debug;
257			$r = 1;
258			$err = 404;
259			}
260			}
261			else {
262			print STDERR "transfer error: couldn't read file '" . $loc . $file . "'.\n" if $debug;
263			}
264			}
265			elsif ($type) {
266			if (!defined $curl) {
267			use WWW::Curl::Easy;
268			# set up curl stuff
269			$curl = new WWW::Curl::Easy;
270			if ($timestamp > 0) {
271			$curl->setopt(CURLOPT_TIMECONDITION, 1); # CURL_TIMECOND_IFMODSINCE
272			$curl->setopt(CURLOPT_TIMEVALUE, $timestamp);
273			}
274			$curl->setopt(CURLOPT_CONNECTTIMEOUT, $connect_timeout);
275			$curl->setopt(CURLOPT_FTP_RESPONSE_TIMEOUT, $ftp_response_timeout);
276			$curl->setopt(CURLOPT_LOW_SPEED_LIMIT, $max_stall_speed);
277			$curl->setopt(CURLOPT_LOW_SPEED_TIME, $max_stall_time);
278			$curl->setopt(CURLOPT_FOLLOWLOCATION, 1);
279			$curl->setopt(CURLOPT_FILETIME, 1);
280			# hook curl transfer functions for local caching
281			$curl->setopt(CURLOPT_WRITEDATA, \%curldata);
282			$curl->setopt(CURLOPT_WRITEFUNCTION, \&write_function);
283			$curl->setopt(CURLOPT_WRITEHEADER, \%curldata);
284			$curl->setopt(CURLOPT_HEADERFUNCTION, \&header_function);
285			}
286			# depending on type check if remote file is newer
287			print STDERR "curl fetch url '" . $source . $file . "'\n" if $debug;
288			$curl->setopt(CURLOPT_URL, $source . $file);
289			$r = $curl->perform;
290			print STDERR "curl return value: " . $err . "\n" if $debug;
291			# use curl to get it and output it directly
292			if ($r == 0) {
293			$err = $curl->getinfo(CURLINFO_HTTP_CODE);
294			if ($err =~ m/^2/ \|\| $err == 304) {
295			if ($curl->getinfo(CURLINFO_CONDITION_UNMET)) {
296			$file_unmodified = 1;
297			}
298			$file_time = $curl->getinfo(CURLINFO_FILETIME);
299			}
300			else {
301			# error stuff ?
302			print STDERR "transfer error: http code " . $err . "\n" if $debug;
303			}
304			}
305			else {
306			# error stuff ?
307			print STDERR "transfer error: " . $curl->strerror($r) . " ($r)\n" if $debug;
308			}
309			}
310			else {
311			print STDERR "transfer error: this source does not have a type\n" if $debug;
312			}
313			last if $file_sent && !$merge;
314			}
315
316			my $extra = '';
317
318			close(FILEHANDLE);
319
320			if ($file_sent && $r == 0 && $err =~ m/^2/ && $filename) {
321			# clean up file and move to correct location
322			if (system("mkdir -p $cache_path$dest_path") == 0) {
323			if (rename($tmp_file, $cache_path . $file)) {
324			utime(time(), $file_time, $cache_path . $file) if $file_time > 0;
325			}
326			else {
327			print STDERR "WARNING: file '$tmp_file' could not be moved to '$cache_path$file'\n";
328			}
329			}
330			else {
331			print STDERR "WARNING: containing path for '$cache_path$file' could not be created\n";
332			}
333			_log($logfile, $file, 200, 'MISS');
334			}
335			else {
336			unlink($tmp_file);
337			if ($file_sent) {
338			if ($filename) {
339			_log($logfile, $file, $err, 'MISS_FAIL_SENT');
340			}
341			else {
342			# It was actually successful, but paths can't be saved...
343			print STDERR "NOTICE: paths cant be saved: '$file'\n" if $debug;
344			_log($logfile, $file, $err, 'MISS');
345			}
346			exit 0;
347			}
348			$extra = '_UNMODIFIED' if $file_unmodified;
349			return_file($cache_path, $file, $logfile, 'HIT_AFTER_FAIL' . $extra) if $filename && -R $cache_path . $file;
350			_log($logfile, $file, 404, 'MISS_FAIL');
351			return_error(404, 'File not found');
352			}
353
354			print STDERR "finished." if $debug;
355
356			exit 0;
357
358			sub header_function {
359			my ($ptr, $data) = @_;
360			if (!${$data->{file_sent}}) {
361			$data->{http_header} = $1 if $ptr =~ m!^HTTP/[0-9.]+\s+(.+?)[\s\r\n]*$!;
362			$data->{content_type} = $1 if $ptr =~ m/^Content-[tT]ype:\s+(.+?)[\s\r\n]*$/;
363			$data->{size} = $1 if $ptr =~ m/^Content-[lL]ength:\s+(.+?)[\s\r\n]*$/;
364			$data->{size} = $1 if $ptr =~ m/^213\s+(.+?)[\s\r\n]*$/;
365			}
366			return length($ptr);
367			}
368
369			sub write_function {
370			my ($ptr, $data) = @_;
371			my $f = ${$data->{fh}};
372			print $f ($ptr);
373			if (!${$data->{file_sent}}) {
374			${$data->{file_sent}} = 1;
375			print STDERR "HTTP header: " . $data->{http_header} . "\n" if $debug && defined $data->{http_header};
376			print STDERR "Content-Type: " . $data->{content_type} . "\n" if $debug && defined $data->{content_type};
377			print STDERR "Content-Length: " . $data->{size} . "\n" if $debug;
378			print "Status: " . $data->{http_header} . "\r\n" if $data->{http_header} && $data->{http_header} !~ m/^2/;
379			print "Content-Type: " . $data->{content_type} . "\r\n" if $data->{content_type};
380			print "Content-Length: " . $data->{size} . "\r\n" if $data->{size} > -1 && !${$data->{merge}};
381			print "\r\n";
382			}
383			print $ptr;
384			return length($ptr);
385			}
386
387			sub _log {
388			my ($logfile, $file, $code, $cached) = @_;
389			my $date = `date`;
390			$date =~ s/[\s\r\n]*$//;
391			open(FILE, ">>" . $logfile) or return;
392			print FILE "[" . $date . "] $file - $code - $cached\n";
393			close(FILE);
394			}
395
396			sub return_file {
397			my ($cache_path, $file, $logfile, $cached)=@_;
398			open(FILE, "<", $cache_path . $file) or do {
399			_log($logfile, $file, 500, $cached);
400			return_error(500, 'Server error');
401			};
402			my $ft = `file -b --mime-type $cache_path$file`;
403			$ft =~ s/[\s\r\n]*$//;
404			print STDERR "mimetype: '$ft'\n" if $debug;
405			print STDERR "size: " . (-s $cache_path . $file) . "\n" if $debug;
406			print "Content-Type: " . $ft . "\r\n";
407			print "Content-Length: " . (-s $cache_path . $file) . "\r\n\r\n";
408			binmode(FILE);
409			my $buf;
410			while (read(FILE, $buf, 1024)) {
411			print $buf;
412			}
413			close FILE;
414			_log($logfile, $file, 200, $cached);
415			exit 0;
416			}
417
418			sub return_error {
419			my ($code, $text) = @_;
420			print "Status: $code $text\r\n\r\n";
421			print STDERR "$code $text.\n" if $debug;
422			exit 0;
423			}