###PERL;
+# proxy.pl is generated from proxy.1.pl
+#
+# This is the proxy software. It's launched as a CGI program by the http server.
+#
+# The proxy:
+# - determines information about the http(s) request,
+# - checks if user is allowed to use it,
+# - forwards the requests using curl,
+# - sends the response back to the user,
+# - saves a redundant copy of the response.
+#
+# It's run with SETUID to have accesss to some files where the www server
+# should not. That's why it has a C wrapper. In modern systems running scripts
+# directly with SETUID is considered unsafe and not allowed.
+# When running with SETUID the program also has to deal with Perl's built-in
+# securuity.
+#
+# Any data comming from standard input, files, environment variables, command
+# line is treated by Perl as unsafe. Any data created by operations on unsafe
+# data is also unsafe. Perl will not allow to use such data to open files (for
+# writing), launch programs, etc.
+# That's why the data has to be validated and made safe, like this:
+# if ($variable =~/^(some-regex)$/) {
+# $variable = $1;
+# }
+#
+# see also:
+# http://perldoc.perl.org/perlsec.html#Taint-mode
+# https://tools.ietf.org/html/rfc2616
+# https://tools.ietf.org/html/rfc3875
+# https://tools.ietf.org/html/rfc2396
+
+
use POSIX qw(strftime);
###UNLOCK_LOG;
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
###PATH;
+# If the special URL is used, instaed of proxying there will be proxy unlocking.
if (($ENV{'HTTP_HOST'} =~ UNLOCK_PROXY_HOST) and (urldecode($ENV{'PATH_INFO'}) =~ UNLOCK_PROXY_PATH)){
unlock();
}
else {
+ # proxy will work only if unlocked
if(access()) {
proxy();
}
}
}
+# The proxying function
sub proxy {
- # srand(time()+$$);
+ # The required information is stored in environment variables (rfc3875).
+ # The HTTPS variable is not defined in rfc3875 (might be a portability
+ # problem?)
- $archive = 0;
+ $archive = 0; # if this http request should be archived
+ # The proxy will not support request methods other than GET, POST, HEAD.
+ # There is no need for it.
if ($ENV{'REQUEST_METHOD'} !~ /^(HEAD|GET|POST)$/) {
return fail("Status: 405 Method Not Allowed\nAllow: GET, POST, HEAD\n","405 Method Not Allowed","The proxy does not support the $ENV{'REQUEST_METHOD'} method.");
}
+ # The proxy may be presented with either a complete URL (when it's a HTTP
+ # proxy) or just the path (when it's a HTTPS proxy).
+ # In this case the URL has to be reconstructed.
if ($ENV{'REQUEST_URI'} =~ /^[a-z]*(:[0-9]*)?:\/\/.*$/){
$URL=$ENV{'REQUEST_URI'};
}
$URL=($ENV{'HTTPS'} eq 'on' ? 'https://' : 'http://').$ENV{'HTTP_HOST'}.$ENV{'REQUEST_URI'};
}
- if (validateurl($URL)) { #validate URL against illegal characters
+ # The URL will now be validated.
+ # Additionally it will be divided in parts which will be stored in variables:
+ # $prot (protocol), $host, $port, $path, $query.
+ if (validateurl($URL)) {
$URL =~ /^(.*)$/;
$URL = $1;
}
return fail("Status: 400 Bad Request\n","400 Bad Request","Invalid URL: $URL.");
}
+ # If port not defined default value is used.
if ($port eq ''){
$port=($ENV{'HTTPS'} eq 'on' ? '443' : '80');
}
-
- if ($host =~ /^[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+$/) {#IP instead of hostname
+
+ # The host can be a hostname or IP.
+ # A request to a private IP number gives users access to the proxy's local
+ # network. This should not be allowed.
+ if ($host =~ /^[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+$/) {
if ($host =~ /^((0*10\..*)|(0*127\..*)|(0*172\.0*((1[6-9])|(2[0-9])|(3[0-1]))\..*)|(0*192\.0*168\..*))$/) {
return fail("Status: 403 Forbidden\n","403 Forbidden","The proxy does not accept a private IP address $host as hostname.");
}
}
+ # Of course, if there is a web server inside the local network and is accessed
+ # by its hostname it can be accessible. But the server which runs the proxy
+ # can have some hostnames defined that point to computers in local network
+ # that are not available from outside. These should be blocked as well.
if ($host =~ BLOCK_HOST) {
return fail("Status: 403 Forbidden\n","403 Forbidden","The proxy does not accept $host as hostname.");
}
+ # The proxy will block any access with a port number that is used by the
+ # proxy. Otherwise it would be possible to create an infinite loop in which
+ # the request is proxied back to the proxy again. Of course, to create such a
+ # loop not only the port number but also the host name is required. But is not
+ # always easy (or possible) to predict if a hostname will point to the proxy
+ # or not. Blocking port numbers is easier.
+ #That's why the proxy should not be installed on the default port numbers, 80
+ # or 443 because then it will not work!
if ($port =~ BLOCK_PORT) {
return fail("Status: 403 Forbidden\n","403 Forbidden","The proxy does not accept port number $port because of infinite loop prevention.");
}
- # do {
- # $temppath=TEMP_PATH.int(rand(100000000)).'_';
- # $headpath=$temppath.'h';
- # $downpath=$temppath.'d';
- # $uppath=$temppath.'u';
- # } while (( -e $headpath) or ( -e $downpath) or ( -e $uppath));
-
- @curl_arg=(CURL_PATH,'-i','-#'); #-s
- @reqhead;
+ @curl_arg=(CURL_PATH,'-i','-#'); # the command line arguments for curl
+ @reqhead; # the HTTP request header
foreach $envk (keys %ENV) {
+ # The relevant http variables either start with HTTP_ or CONTENT_.
if ($envk =~ /^(HTTP_[A-Z0-9_]+)$/) {
$headname=formatheader($1);
}
else {
next;
}
+ # test against illegal characters
if ($ENV{$envk} =~ /^([\x20-\x7e]*)$/) {
$headval=$1;
}
else {
next;
}
+
+ # Some header fields should not be forwarded.
if(lc($headname) =~ REQUEST_HEADER_BLOCK) {
next;
}
push @curl_arg, $headarg;
push @reqhead, $headarg;
}
+
+ # curl uses its default values of User-agent and Accept header fields unless
+ # they are defined in the command line.
+ # If the original request doesn't contain these fields this will undefine them:
unless (exists $ENV{'HTTP_USER_AGENT'}) {
push @curl_arg, '-H';
push @curl_arg, 'User-Agent:';
}
if ($ENV{'REQUEST_METHOD'} eq 'POST'){
- # binmode(STDIN) or return fail("Status: 500 Internal Server Error\n","500 Internal Server Error","Failed to switch STDIN to binary mode.");
- # open($upfile,">",$uppath) or return fail("Status: 500 Internal Server Error\n","500 Internal Server Error","Failed to create temporary file.");
- # binmode ($upfile) or return fail("Status: 500 Internal Server Error\n","500 Internal Server Error","Failed to switch temporary file to binary mode.");
-
- # $buffer;
- # while (read (STDIN,$buffer,65536)) {
- # unless (print ($upfile $buffer)) {
- # return fail("Status: 500 Internal Server Error\n","500 Internal Server Error","Failed to write to temporary file.");
- # }
- # }
- # close ($upfile);
- # $craetedup=1;
-
- $postdata=1;
+ $postdata=1; # if there is data to pe posted
push @curl_arg, '--data-binary';
- # push @curl_arg, '@'.$uppath;
push @curl_arg, '@-';
-
}
- $archpath = makepath($prot, $host, $port, $path);
+ # The path for archiving the HTTP request is made, the required directories
+ # are created.
+ # If this fails the request will not be archived but will still be proxied.
+ $archpath = makepath($prot, $host, $port, $path, $query);
if ($archpath) {
$archive = 1;
- if ($query or $postdata) {
+ if ($postdata) {
+ # If this is a POST request the URL is not enough to identify it. To the
+ # path will be added a number. Also the request header and post data will
+ # be archived and not only the response header and response data.
for (my $i = 0; ;++$i) {
$respcontpath=$archpath.'@v-'.$i;
$respheadpath=$archpath.'@h-'.$i;
$postheadpath=$archpath.'@g-'.$i;
$postcontpath=$archpath.'@u-'.$i;
- $postquerpath=$archpath.'@q-'.$i;
- if ((! -e $respcontpath) and (! -e $respheadpath) and (! -e $postheadpath) and (! -e $postcontpath) and (! -e $postquerpath)) {
+ if ((! -e $respcontpath) and (! -e $respheadpath) and (! -e $postheadpath) and (! -e $postcontpath)) {
last;
}
}
- if ($query) {
- if (open ($postquerfile, ">", $postquerpath)) {
- print $postquerfile "$query\n";
- close($postquerfile);
- }
- }
-
- if ($postdata) {
- if (open ($postheadfile, ">", $postheadpath)) {
- foreach $line (@reqhead) {
- print $postheadfile "$line\n";
- }
+ # The request header is written.
+ if (open ($postheadfile, ">", $postheadpath)) {
+ foreach $line (@reqhead) {
print $postheadfile "$line\n";
- close ($postheadfile);
}
+ print $postheadfile "$line\n";
+ close ($postheadfile);
}
+
}
else {
$respcontpath=$archpath.'@v';
$respheadpath=$archpath.'@h';
- $postheadpath='';
- $postcontpath='';
- $postquerpath='';
}
}
else {
push @curl_arg, $URL;
+ # The pipes for communication with curl are created.
pipe ($curloutrd, $curloutwr) or return fail("Status: 500 Internal Server Error\n","500 Internal Server Error","Failed to create stdout pipe.");
pipe ($curlerrrd, $curlerrwr) or return fail("Status: 500 Internal Server Error\n","500 Internal Server Error","Failed to create stderr pipe.");
if ($postdata){
pipe ($curlinrd, $curlinwr) or return fail("Status: 500 Internal Server Error\n","500 Internal Server Error","Failed to create stdin pipe.");
}
+ # curl, the program that will send the forwarded request is launched here
$curlpid = fork();
unless (defined $curlpid) {
return fail("Status: 500 Internal Server Error\n","500 Internal Server Error","fork() failed.");
close ($curloutrd);
close ($curlerrrd);
+ # The input and outputs of curl are redirected to pipes.
open(STDERR, ">&=" . fileno($curlerrwr)) or die "Failed to open stderr pipe.\n";
open(STDOUT, ">&=" . fileno($curloutwr)) or die "Failed to open stdout pipe.\n";
close ($curlerrwr);
if($postdata) {
+ # If this is a POST request the post data is available on the standard
+ # input. It will be piped to curl and written to a file (if successfully
+ # opened).
+ # Originally this part would be in a separate thread but:
+ # 1. It didn't work. Not sure why.
+ # 2. It was not necaessary.
+
# $curlpidin = fork();
# unless (defined $curlpidin) {
# $forceexit=1;
# }
# unless ($curlpidin) {
+
close($curlinrd);
binmode($curlinwr) or die "Failed to switch stdin pipe to binary mode.\n";
binmode(STDIN) or die "Failed to switch STDIN to binary mode.\n";
if ($postcontopen) {
close($postcontfile);
}
+
# exit 0;
# }
# close ($curinwr);
# close ($curlinrd);
}
- $safelength=1;
- $definedlength=0;
- $safeerror=1;
- $lastskipped=1;
- $forceexit=0;
+ $safelength=1; # if Content-length is safe to be forwarded
+ $definedlength=0; # if Content-length is defined
+ $safeerror=1; # if it's safe to send an error message.
+ $lastskipped=1; # if the previous header field was not forwarded
+ $forceexit=0; # if the proxy should exit with error
if ($line = <$curloutrd>) {
$line =~ s/\r?\n$//;
+ # The first line is the status.
if ($line =~ /^HTTP\/[0-9]+\.[0-9]+ ([0-9]+ .*)$/) {
$status =$1;
@resphead=('Status: '.$status);
+ # If the status is not 2XX and this URL was already archived before it
+ # should not be overwritten.
+ # Otherwise it can happen that, for example, after refreshing the content
+ # previously downloaded will be overwritten with a "304 Not Modified" and
+ # lost.
+
if(($status !~ /^2[0-9][0-9]/) and (-e $respcontpath)){
$archive=0;
}
+ # now read the header lines
while ($line = <$curloutrd>) {
$line =~ s/[\r\n]$//g;
+ # empty line (double \n) meane the end of the header.
if($line eq ''){
last;
}
+ # If line starts with space or tab, it's a continuation of the previous
+ # line.
if($line =~ /^[ \t](.*)$/){
+ # Continuation of a skipped line should be skipped too.
if ($lastskipped) {
next;
}
next;
}
+ # If one of these header fields is present it can not be assumed that
+ # the received value of Content-length is also correct for the forwarded
+ # content.
if($headname eq 'transfer-encoding') {
$safelength = 0;
}
$headvalue =~ s/[\r\n \t]*$//;
$contentlength = int($headvalue);
}
+
+ # Some header fields should not be forwarded.
if($headname =~ RESPONSE_HEADER_BLOCK) {
$lastskipped =1;
next;
push @resphead, $line;
}
- if ($lengthdefined and ($lengthsafe or ($contentlength==0))) {
+ # Only add the Content-length header if it's safe to do so.
+ if ($lengthdefined and ($safelength or ($contentlength==0))) {
push @resphead, 'Content-length: '.$contentlength;
}
+ # After forwarding the response header it's too late to send any error
+ # messages.
$safeerror=0;
+ # Forward the header and safe it to file if possible and allowed.
if ($archive) {
$respheadopen = open($respheadfile, ">", $respheadpath);
}
close $respheadfile;
}
+ # Now forward the actual content and safe it to file if possible and
+ # allowed.
if ( ! binmode ($curloutrd)) {
- # print "FAIL 1\n";
$forceexit=1;
}
elsif ( ! binmode (STDOUT) ) {
- # print "FAIL 2\n";
$forceexit=1;
}
else {
+ # Create the file only if there was content received. No 0-byte files.
$firstline=1;
while (read ($curloutrd,$buffer,1024)) {
unless (print (STDOUT $buffer)) {
}
}
+ # Ok, done. Now wait for curl to exit. (Should have already happened).
waitpid($curlpid,0);
if ($? != 0) {
+ # Generate error message if possible.
if ($safeerror) {
$errormsg='';
while ($line = <$curlerrrd>) {
# }
# }
+ # Send error message if it;s safe to do so.
if($safeerror){
return fail("Status: 500 Internal Server Error\n","500 Internal Server Error",$errormsg);
}
}
-sub access { #kind of doubles the functionality of access.pl but for http
+# This function checks if the user has unlocked the proxy. Nonzero means yes.
+sub access {
if($ENV{'HTTP_HOST'} =~ UNLOCK_PROXY_HOST){
return 1;
}
+
+ # Check if IP
if ($ENV{'REMOTE_ADDR'} =~ /^([0-9]+\.[0-9]+\.[0-9]+\.[0-9]+)$/) {
$IP = $1;
+
+ # 127.0.0.1 is always allowed. All https requests are tunnelled through
+ # 127.0.0.1.
if ($IP eq '127.0.0.1') {
return 1;
}
+
+ # If access file doesn't exist the proxy is not unlocked for this IP.
$accesspath=ACCESS_PATH.$IP;
if (! (-e $accesspath)) {
return 0;
}
elsif (open ($accessfile,"+<",$accesspath)) {
+ # The access file has to be locked otherwise one process may read it while
+ # another one updates it.
unless (flock ($accessfile, 2)) {
close ($accessfile);
return 0;
}
+ # First line is the timestamp of proxy unlocking. Second line is the
+ # timestamp of last access.
$unlocktime=<$accessfile>;
$lasttime=<$accessfile>;
$unlocktime =~ s/[\r\n]//g;
$lasttime =~ s/[\r\n]//g;
+ # The timestamps must be numbers.
if ($unlocktime =~ /^([0-9]+)$/) {
$unlocktime=int($1);
}
}
if ((abs($accesstime-$unlocktime)>$timeout_unlock) or (abs($accesstime-$lasttime)>$timeout_inact)){
+ # If too much time passed proxy is not unlocked any more. Also the
+ # access file is now useless and will be removed.
close ($accessfile);
unlink $accesspath;
return 0;
}
else {
+ # the proxy is unlocked. The access file will now be updated.
if (seek($accessfile, 0, 0)) {
print $accessfile "$unlocktime\n$accesstime\n";
truncate ($accessfile , tell($accessfile));
}
}
+# Function to unlock the proxy.
sub unlock {
if ($ENV{'REMOTE_ADDR'} =~ /^([0-9]+\.[0-9]+\.[0-9]+\.[0-9]+)$/) {
$IP=$1;
}
+ # If the request method is GET the CGI parameters must be taken from the
+ # query string (part of URL).
if ($ENV{'REQUEST_METHOD'} eq 'GET') {
%CGI=getcgi($ENV{'QUERY_STRING'});
}
+ # If request method is POST the CGI parameters must be taken from standard
+ # input.
elsif ($ENV{'REQUEST_METHOD'} eq 'POST'){
+ #Check content-type. Multipart is not supported.
if ($ENV{'CONTENT_TYPE'} eq 'application/x-www-form-urlencoded'){
%CGI=getcgi( <STDIN> );
}
return unlockpage("Unsupported method: $ENV{'REQUEST_METHOD'}.","Status: 405 Method Not Allowed\nAllow: GET, POST\n");
}
+ # If there was an IP in the form it must be used instead.
if ($CGI{'ip'} =~ /^([0-9]+\.[0-9]+\.[0-9]+\.[0-9]+)$/) {
$IP=$1;
}
if ($IP eq '') {
- return unlockpage("$Invalid IP.","Status: 403 Forbidden\n");
+ return unlockpage("Invalid IP.","Status: 403 Forbidden\n");
}
if ($CGI{'username'} eq ''){
}
$passpath = PASS_PATH.$CGI{'username'};
-
+ # Open file to read user's password.
open($passfile, "<", $passpath) or return unlockpage('Wrong username or password.',"Status: 403 Forbidden\n");
$pass = <$passfile>;
close($passfile);
$pass =~ s/[\r\n]//g;
+ # The password is stored in URL-encoded form.
$pass = urldecode($pass);
if ($pass ne $CGI{'password'}){
return unlockpage('Wrong username or password.',"Status: 403 Forbidden\n");
}
+ # All unlocking access must be logged: time, IP, user. The server owner must
+ # be able to know who did what with the proxy (in case of legal problems).
open ($logfile, ">>", UNLOCK_LOG) or return unlockpage("Couldn't log your action.","Status: 500 Internal Server Error\n");
print $logfile strftime("%d.%m.%Y %H:%M:%S", gmtime($accesstime))." $IP $CGI{'username'}\n";
close($logfile);
+ # Ok, unlocked. Create access file.
$accesspath=ACCESS_PATH.$IP;
open ($accessfile,">",$accesspath) or return unlockpage("$accesspath","Status: 403 Forbidden\n");
print $accessfile "$accesstime\n$accesstime\n";
}
+# The function to get CGI parameters from string.
+# Format is: name=url_encoded_value&name=url_encoded_value& ... &name=url_encoded_value
sub getcgi {
my $arg;
my $varl;
return %cgi;
}
+# Function for decoding URL-encoded text
sub urldecode {
my $t = $_[0];
$t =~ s/\+/ /g;
return $t;
}
+# Function for formatting header field names.
+# The Environment variable name is like this: HTTP_HEADER_NAME or HEADER_NAME.
+# But should be Header-Name.
+# Actually the names are case-insensitive but in practise they often look like
+# this. (Otherwise suspicious?)
sub formatheader {
my $t = $_[0];
$t =~ s/^HTTP_//;
return $t;
}
+# Function for showing the proxy unlock form page.
+# arguments: 1 - additional message (optional), 2 - additional header fields
+# (optional)
sub unlockpage {
(my $message, my $header)=@_;
if($header ne ''){
print "</ul></body></html>\n";
}
+# Function for showing error messages.
+# Arguments: 1 - header fields, 2 - page title, 3 - error message text.
sub fail {
(my $header, my $title, my $message)=@_;
if($header ne ''){
print "</body></html>\n";
}
+# Function to show the message after unlocking the proxy.
sub unlockedpage {
print "Content-type: text/html\n\n";
print '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "">';
print "</ul></body></html>\n";
}
+# Function to show the message when proxy not unlocked.
sub noaccess {
print "Status: 403 Forbidden\n;";
print "Content-type: text/html\n\n";
print "</body></html>\n";
}
+# Function to show debug information. Not used any more.
sub debag {
print "Content-type: text/plain\n\n";
foreach $envk (keys %ENV) {
print 'URL: ',$URL,"\n";
}
+# Function to check URL and divide in parts: protocol, hostname, port number,
+# path, query string.
sub validateurl {
my $url = $_[0];
$prot;
return 1;
}
+# Function to convert URL to archive path. Also creates required directories.
+# Returns the path on success and empty string on fail.
+# Inspired by the MIRA browser.
sub makepath {
- #inspired by the MIRA browser!
- (my $prot, my $host, my $port, my $path) = @_;
+ (my $prot, my $host, my $port, my $path, my $query) = @_;
my $archpath = ARCH_PATH;
+ # First subdir: protocol @p port_number
if ($prot =~ /^(https?)$/) {
$archpath .= $1;
}
}
}
+ # Host name: each segment between dots is a subdir, revedrsed order, last part
+ # ends with @n.
+ # For example www.example.com becomes
+ # ... /com/example/www@/ ...
+
+ # When segment is longer than 120 characters it's divided into 64 character
+ # parts ending with '-' until the last one is not longer than 120.
+ # For example
+ # www.aaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffgggggggggghhhhhhhhhhiiiiiiiiiijjjjjjjjjjkkkkkkkkkkllllllllllmmmmmmmmmmnnnnnnnnnnoooooooooopppppppppprrrrrrrrrrssssssssssttttttttttuuuuuuuuuuwwwwwwwwwwyyyyyyyyyyzzzzzzzzzz.com
+ # becomes
+ # ... /com/aaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffgggg-/gggggghhhhhhhhhhiiiiiiiiiijjjjjjjjjjkkkkkkkkkkllllllllllmmmmmmmm-/mmnnnnnnnnnnoooooooooopppppppppprrrrrrrrrrssssssssssttttttttttuuuuuuuuuuwwwwwwwwwwyyyyyyyyyyzzzzzzzzzz/www@n/ ...
+
if($host =~ /^([A-Za-z0-9\-\.]+)$/) {
$host = $1;
}
}
}
+ # Path: each segment between '/' is subdir. The segment after the last '/' is
+ # not a subdir - it is part of the file name. And it will be appended with
+ # some characters outside of this function: @g, @h, @u or @v.
+ # Exception: when there is a query string the last segment is a subdir too and
+ # ends with q.
+ # Characters that are not letters or numbers or '_' or '.' are encoded. Like
+ # in URL-encoding but with '@' instead of '%'.
+ # When segment is longer than 120 characters it's divided into 64 character
+ # parts ending with '-' until the last one is not longer than 120.
+
+ # For example:
+ # /some/path/?a=1 becomes ... /some/path@q/ ...
+ # /some/other-path becomes ... /some/other@2Dpath
+ # /path/aaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffgggggggggghhhhhhhhhhiiiiiiiiiijjjjjjjjjjkkkkkkkkkkllllllllllmmmmmmmmmmnnnnnnnnnnoooooooooopppppppppprrrrrrrrrrssssssssssttttttttttuuuuuuuuuuwwwwwwwwwwyyyyyyyyyyzzzzzzzzzz/yyy
+ # becomes
+ # ... /path/aaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffgggg-/gggggghhhhhhhhhhiiiiiiiiiijjjjjjjjjjkkkkkkkkkkllllllllllmmmmmmmm-/mmnnnnnnnnnnoooooooooopppppppppprrrrrrrrrrssssssssssttttttttttuuuuuuuuuuwwwwwwwwwwyyyyyyyyyyzzzzzzzzzz/yyy
+
$path =~ s/^\///;
while ((my $ind = index ($path, '/'))>=0) {
my $part = substr $path, 0, $ind;
$path= substr $path, $ind+1;
- $part =~ s/[^A-Za-z0-9_\.]/sprintf ("@%02X",ord($1))/eg;
+ $part =~ s/([^A-Za-z0-9_\.])/sprintf ("@%02X",ord($1))/eg;
while (length ($part) > 120) {
$archpath .= '/'.substr($part,0,64).'-';
}
}
}
- $path =~ s/[^A-Za-z0-9_\.]/sprintf ("@%02X",ord($1))/eg;
+ $path =~ s/([^A-Za-z0-9_\.])/sprintf ("@%02X",ord($1))/eg;
while (length ($path) > 120) {
$archpath .= '/'.substr($path,0,64).'-';
$path = substr($path,64);
}
}
}
+
+ if ($query) {
+ # query string: The last part is not a subdir - it is part of the file name.
+ # And it will be appended with some characters outside of this function: @g,
+ # @h, @u or @v.
+ # When Query string is longer than 240 characters it's divided into 128
+ # character parts ending with '-' until the last one is not longer than 240.
+ # Characters that are not letters or numbers or '_' or '.' are encoded. Like
+ # in URL-encoding but with '@' instead of '%'.
+ # When segment is longer than 120 characters it's divided into 64 character
+ # parts ending with '-' until the last one is not longer than 120.
+ # The '?' at the beginning is not part of the query string.
+ # For example:
+ # ?a=1&b=%25%5E%26 becomes ... /a@3D1@26b@3D@2525@255E@2526
+ # ?a=aaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffgggggggggghhhhhhhhhhiiiiiiiiiijjjjjjjjjjkkkkkkkkkkllllllllllmmmmmmmmmmnnnnnnnnnnoooooooooopppppppppprrrrrrrrrrssssssssssttttttttttuuuuuuuuuuwwwwwwwwwwyyyyyyyyyyzzzzzzzzzz&b=aaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffgggggggggghhhhhhhhhhiiiiiiiiiijjjjjjjjjjkkkkkkkkkkllllllllllmmmmmmmmmmnnnnnnnnnnoooooooooopppppppppprrrrrrrrrrssssssssssttttttttttuuuuuuuuuuwwwwwwwwwwyyyyyyyyyyzzzzzzzzzz
+ # becomes
+ # ... /a@3Daaaaaaaaaabbbbbbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffgggggggggghhhhhhhhhhiiiiiiiiiijjjjjjjjjjkkkkkkkkkkllllllllllmmmm-/mmmmmmnnnnnnnnnnoooooooooopppppppppprrrrrrrrrrssssssssssttttttttttuuuuuuuuuuwwwwwwwwwwyyyyyyyyyyzzzzzzzzzz@26@b@3Daaaaaaaaaabbbb-/bbbbbbccccccccccddddddddddeeeeeeeeeeffffffffffgggggggggghhhhhhhhhhiiiiiiiiiijjjjjjjjjjkkkkkkkkkkllllllllllmmmmmmmmmmnnnnnnnnnnoooooooooopppppppppprrrrrrrrrrssssssssssttttttttttuuuuuuuuuuwwwwwwwwwwyyyyyyyyyyzzzzzzzzzz
+ $query =~ s/([^A-Za-z0-9_\.])/sprintf ("@%02X",ord($1))/eg;
+
+ $archpath .= '/'.$path.'@q';
+
+ $path = $query;
+ unless (-d $archpath)
+ {
+ unless (mkdir $archpath) {
+ return '';
+ }
+ }
+
+ while (length ($path) > 240) {
+ $archpath .= '/'.substr($path,0,128).'-';
+ $path = substr($path,128);
+ unless (-d $archpath)
+ {
+ unless (mkdir $archpath) {
+ return '';
+ }
+ }
+ }
+ }
$archpath .= '/'.$path;
return $archpath;
}
bicyclesonthemoon.info / projects / yplom / proxy / commitdiff