#!/usr/bin/perl # # put.perl # Version 0.1 # for use with Apache (not that I've tested it with anything else) # # Copyright 1997 Purple Frog Software # All rights reserved. # http://www.purplefrog.com/put/ # # There is a licensing fee associated with the use of this software. # # This software does not implement If-Match headers # If this script is not suid root, it will be unable to assume the # identities specified in the put.access Access map. This will result # in a "500 Internal Server Error" returned to the PUTting client and # a "Failed to setuid() or setgid()" being logged to stderr (which usually # appears in the ErrorLog configured for Apache). # The exception to this caveat is if all your Access Map entries # specify the same UID and GID as the perl script is spawned under. # The script's process will not notice its failure to setuid and # setgid because it will have already have the proper identity and # will slog onward. # If you edit this file, it will probably clear the setuid bit and you # will get an error. # This script is fairly terse with its error messages to the HTTP # client because Security Through Obscurity isn't a bad security # practice, it just shouldn't be your only one. More useful errors # are printed to stderr which the HTTPD should be logging somewhere. # If you have problems you can't explain or solve, find the # appropriate log file and graze. If you can't find the log file then # open(STDERR, ">>/tmp/put.perl.log"); ###################################################################### # # The file put.access lives in the same directory with put.perl and # contains the Access Map. The access map isn't included in-line # because editing a setuid file (this script should be setuid root for # full functionality) clears the setuid bit, and the put.access Access # Map will probably be edited several times over the lifetime of the # installation. # { # locate the put.access file containing the Access Map my($fname) = $0; my($suffix) = "put.access"; if ($fname =~ m-^/-s) { # We have a fully qualified path. Replace the last bit. $fname =~ s-/[^/]*$-/$suffix-s; } else { # we have a basename. Search the $PATH for the executable. my($dir); undef $fname; foreach $dir (split(":",$ENV{PATH})) { if ( -x "$dir/$0" ) { $fname = "$dir/$suffix"; last; } } } if ( ! -f $fname ) { warn "$0: unable to locate Access Map $fname"; &Im_misconfigured(); exit 1; } $fname =~ /^/; $fname = $'; unless ( defined (do $fname) ) { warn "$0: error parsing/executing Access Map $fname"; &Im_misconfigured(); exit 1; } } # # I doubt many HTML editors show you the response code, but spewing # version info could be useful in security audits (or attacks. Damn # the two edged sword called life). # $version_html = <

put.perl Version 0.1

Copyright © 1997 Purple Frog Software
All rights reserved. EOF ; ###################################################################### # # error handlers # ###################################################################### sub illegal_method() { my ($mname) = @_; my ($code) = "405 Method Not Allowed"; print < $code

$code

This script can only process PUT requests, not $mname requests. $version_html EOF ; } ######## sub illegal_filename() { my ($sname) = @_; my ($code) = "406 Not Acceptable"; print < $code

$code

$sname

The URL you attempted to PUT contained an illegal sequence of characters. $version_html EOF ; } ######## sub Im_misconfigured() { my ($sname) = @_; my ($code) = "500 Internal Server Error"; print < $code

$code

The PUT handler script is misconfigured. EOF ; if ( defined($ENV{SERVER_ADMIN}) ) { print " Please contact the webmaster.\n\n"; } &dump_env(); print $version_html; print "\n"; } ######## sub permission_denied { my ($code) = "403 Forbidden"; print < $code

$code

You are not authorized to upload that document. $version_html EOF ; #'`; print "\n"; } ######## sub download_error { my ($code) = "400 Bad Request"; print < $code

$code

I encountered an error while receiving your document. $version_html EOF ; } ######## sub storage_error { my ($code) = "406 Not Acceptable"; print < $code

$code

I encountered an error while storing your document. $version_html EOF ; } ######## sub dump_env { # This routine is strictly for debugging purposes. # Enabling it during production operation could be a breach of # "Security Through Obscurity". return; print "

Environment dump

\n\n"; print "

%ENV

\n\n"; foreach (sort {$a cmp $b} keys(%ENV)) { print "\$ENV{$_} = $ENV{$_}
\n"; } $bytes_read = read(STDIN, $_, $ENV{CONTENT_LENGTH}); s/&/&/g; s//>/g; print "

input

\n\n"; print "

\n", $_, "\n

\n"; print "$bytes_read bytes read\n"; } ###################################################################### # # PUT handlers # ###################################################################### sub standard { my($fname_) = @_; $fname_ =~ /^/; my ($fname) = ($'); #'; # The filename is theoretically tainted, but it has passed our # access checks. unless (open (FILE, ">$fname")) { warn "$0: Unable to open $fname for write as uid=$>, gid=$): "; &permission_denied(); return; } local ($_); my($clen) = $ENV{CONTENT_LENGTH}; my($blksz, $rval, $sz) = (4096); while (1) { if (defined($clen) && $clen<$blksz) { $sz = $clen; } else { $sz = $blksz; } $rval = read (STDIN, $_, $sz); if ($rval < 0 ) { warn "$0: read error on STDIN: "; &download_error(); return; } last if ($rval==0); unless (print FILE $_) { warn "$0: write error to FILE: "; &storage_error(); return; } $clen -= $rval; } close(FILE); # this is a stupid place to log it. print STDERR "$0: upload by '$ENV{REMOTE_USER}' into $fname\n"; my($code); $code = "201 Created"; #$code = "501 Success"; # for debugging. Navigator doesn't give info if the PUT is successful print < $code

$code

File uploaded successfully. $version_html EOF ; #'`; } # # main control flow # if ($ENV{REQUEST_METHOD} ne "PUT") { &illegal_method($ENV{REQUEST_METHOD}); } # these variables are part of the CGI spec. $remote_user = $ENV{REMOTE_USER}; $path_translated = $ENV{PATH_TRANSLATED}; $script_name = $ENV{REDIRECT_SCRIPT_URL}; # well, this one isn't, but it's used by Apache, and I need it because SCRIPT_NAME will contain the name of this perl script instead of the URL that was requested. Narf! $script_name = $ENV{REDIRECT_URL} unless defined $script_name; $script_name = $ENV{SCRIPT_NAME} unless defined $script_name; if ($script_name =~ m-/\.-) { &illegal_filename($script_name); exit 1; } my($found) = (0); foreach (@access_map) { my ($ruser, $prefix, $uname, $gname, $umask, $handler, @args) = @{$_}; if ( ( $ruser eq "" # any $remote_user matches || $ruser eq $remote_user # only this user matches ) && substr($script_name, 0, length($prefix)) eq $prefix) { my($uid, $gid); if ($uname =~ /^\d+$/) { $uid = $uname; } else { $uid = getpwnam($uname); } if ($gname =~ /^\d+$/) { $gid = $gname; } else { $gid = getgrnam($gname); } if (!defined($uid) || !defined($gid)) { warn "$0: Failed to getpwnam($uname) or getgrnam($gname). [$uid, $gid]"; &Im_misconfigured(); exit 1; } $> = $uid; $) = $gid; if ($> ne $uid || $) ne $gid) { warn "$0: Failed to setuid($uid) or setgid($gid). [$>, $)]"; &Im_misconfigured(); exit 1; } umask $umask; { local (@_) = ($path_translated, @args); # "Hey, Rocky. Wanna watch me pull a rabbit out of my hat?" # It seems that omitting the parenthesis on a subroutine call # passes @_. How convenient! We can trap a misconfigured # handler without eval-ing the contents of $path_translated, # which could be maliciously constructed. unless (eval "&$handler") { warn "$0: error eval-ling handler $handler: $@"; &Im_misconfigured(); exit 1; } } $found = 1; last; } } if (!$found) { warn "$0: no matching entry found for user `$remote_user' and URL `$script_name'\n"; &permission_denied(); exit 1; } exit 0;