#!/usr/local/bin/perl -w # # This is a CGI script to remotely update a web site # It takes submitted data sent by the uptow script or a similar application # and stores the data in a desired place within the $Dest_root directory tree. # # This script is a server part of a HTTP copy facility, to take a file # from a remote client-uploader (uptow, etc). The uploader submits a # file as a PUT request to a HTTP server. Upon receiving this kind of request, # the HHTP server parses it and calls the present script, passing request # headers as env variables, and the PUT message as this script's standard # input. # # Thus this script should receive the following environment # # CONTENT_LENGTH=10 # CONTENT_TYPE=text/plain; filename="data.txt" # DOCUMENT_ROOT=/w/data/htdocs # GATEWAY_INTERFACE=CGI/1.1 # HTTP_HOST=localhost:80 # HTTP_USER_AGENT=UPTOW/1.3 # PATH_INFO=/mysite/dev/ # PATH_TRANSLATED=/w/data/htdocs/mysite/dev/ # QUERY_STRING= # REMOTE_ADDR=127.0.0.1 # REMOTE_PORT=34022 # REQUEST_METHOD=PUT # REQUEST_URI=/cgi-bin/oleg/test-cgi-my/mysite/dev/ # SCRIPT_NAME=/cgi-bin/admin/Update-w-Taker.pl # SERVER_ADMIN=oleg@hostname.org # SERVER_NAME=hostname.org # SERVER_PORT=80 # SERVER_PROTOCOL=HTTP/1.0 # SERVER_SOFTWARE=Apache/1.3.6 (Unix) # TZ=GMT # # Of interest (importance) to us is the REQUEST_METHOD, which must be PUT. # HTTP_USER_AGENT tells the name and the version of the agent, # just for the reference. PATH_INFO tells the directory to upload the file to. # PATH_TRANSLATED is the same path with the server's DocumentRoot prepended. # When the request method is PUT, CONTENT_TYPE and CONTENT_LENGTH env # variables _must_ be present, to tell the message size and data format. # # The content-type of a submitted file must be # application/x-octet-stream-b2a; filename="basename" # text/plain; filename="basename" # This content is stored in a file with the given 'basename' in a directory # specified by the PATH_INFO parameter, after prepending a $Dest_root. # Thus it is generally impossible to place the content outside of the # $Dest_root tree. Alas, symbolic directory links may defeat this. The file # is created if needed. The script must have permissions to write into this # file (or create it). This script responds in "201 Created" HTTP code, # or in one of the HTTP error codes. # # The media type of the CONTENT_TYPE header tells if the received # content was encoded. Unfortunately, some web proxies and gateways # (notably Raptor 5.0) are not 8-bit transparent: they don't like # zero bytes. Therefore, before we push a binary file, we encode it # by representing each byte in two ASCII bytes (in hex). The media type of # "application/x-octet-stream-b2a" tells then if the content was encoded. # I realize the proper place to specify encoding is a Transfer-encoding # HTTP request header. Alas, Apache 1.2 and 1.3 accept only one value for this # header: "Transfer-encoding: chunked" # Any other value in Transfer-encoding results in a BAD_REQUEST error. # See http_protocol.c, line 1319 of Apache 1.2 distribution. # # All activity is logged. # # See # http://zowie.metnet.navy.mil/~spawar/JMV-TNG/Publishing.html # for more details # # $Id: Update-w-Taker.pl,v 2.0 1999/11/02 22:00:53 oleg Exp oleg $ use integer; $Log_file = "/tmp/thw-taker.log"; $Dest_root = "/w/data"; # The root of the destination # Tell the client off (with a status in $1 and reason in string $2) # Status may be omitted sub bail_out { my $status = @_ > 1 ? shift : "400 Bad Request"; print "Status: $status\n"; print "Content-type: text/html\n\n"; # Two \n\n terminate the headers print "
$_[0] \n"; print STDERR "\n***>Error: $status\n $_[0] \n\n"; close STDERR; exit 4 } # Take the content place it into a file whose path is in $1. $2 tells # if the content was hex-encoded. If it is, it would be decoded (packed). # The Content-length, the length of the encoded content, must be even # in this case. sub take_content { my $file_path = shift; my $encoding = shift; my $to_read = $ENV{CONTENT_LENGTH}; $to_read || bail_out "411 Length required", "CONTENT_LENGTH is missing"; print STDERR "Receiving $to_read bytes from $ENV{REMOTE_ADDR} into $file_path\n"; open(PUT_FILE,"> $file_path") || bail_out "403 Forbidden", "$file_path is not writable, $!"; my $chunk_size = 1024; my $chunk; # Note, $chunk_size must be even! binmode STDIN; binmode PUT_FILE; if( $encoding ) { ($to_read & 1) && bail_out "Read the odd number of encoded bytes: $to_read"; my $last_nibble = ""; # if we read a packet of an odd size, below while ( $to_read > 0 && ($read_res = sysread STDIN,$chunk, ($chunk_size < $to_read ? $chunk_size : $to_read))) { if( $last_nibble ) { $chunk = $last_nibble . $chunk; $last_nibble = ""; } ( length($chunk) & 1) && ($last_nibble = chop $chunk); syswrite PUT_FILE,pack("H*",$chunk),length($chunk)/2 || bail_out "$file_path write error $!"; $to_read -= $read_res; } $last_nibble && bail_out "500 Read Error", "Failed to read the input completely, last_nibble $last_nibble: $!"; } else { while ( $to_read > 0 && ($read_res = sysread STDIN,$chunk, ($chunk_size < $to_read ? $chunk_size : $to_read))) { syswrite PUT_FILE,$chunk,$read_res || bail_out "$file_path write error $!"; $to_read -= $read_res; } } $to_read == 0 || bail_out "500 Read Error", "Failed to read the input completely: $!"; close PUT_FILE; } # Main module open(STDERR,">>$Log_file") || bail_out "500 Failed to open the Log", "Failed to open the log file $Log_file"; ($req_method = $ENV{REQUEST_METHOD}) || bail_out "REQUEST_METHOD is missing: the script isn't called by a HTTP server"; $req_method eq "PUT" || bail_out "405 Method not allowed", "$req_method method is invalid or not allowed"; # IIS prepends the name of the script to the PATH_INFO # so we remove it if we come across it my $path_info = $ENV{PATH_INFO}; $path_info =~ s/\A$ENV{SCRIPT_NAME}//; $path_info || bail_out "PATH_INFO is missing: the script isn't called by a HTTP server"; my $content_type; ($content_type = $ENV{CONTENT_TYPE}) || bail_out "CONTENT_TYPE is missing: the request to publish does not have content"; $content_type =~ m!(\w+/[0-9a-zA-Z.:-]+);\s+filename="(.+?)"! || bail_out "Can't figure out the basename from $content_type"; my $media_type = $1; my $file_path = "$Dest_root$path_info/$2"; $file_path =~ s![/\\]+!/!g; # replace double-slashes-backslashes # with a single slash # Do some sanity checking on the file path.... for($file_path) { ( m![\n\r&\$\|]! or m!/\.\./! ) and bail_out "Bad filename. Get a life!"; } if( $media_type eq "text/plain" ) { take_content($file_path,0) } elsif ( $media_type eq "application/x-octet-stream-b2a" ) { take_content($file_path,1) } else { bail_out "Invalid media type $media_type" } close STDERR; print "Status: 201 Created $file_path\n\n"; exit 0;