#!/usr/local/bin/perl -T

# This script allows Apache to "publish" files created with
# Netscape Navigator Gold or one of the other HTML editors.
# It will create the new file in a temporary location
# such as /usr/tmp/incoming, or in the document root.  If
# the user tries to publish a tree of documents, the entire
# tree will be created.
#
# For the apache server, install this script as /cgi-bin/nph-publish
# and add the following line to srm.conf:
#
#   Script PUT /cgi-bin/nph-publish
#
# After you restart the server all PUT (publish) requests will be
# passed to this script for handling. 
#
# Change the $UPLOADS variable to point to the directory in
# which uploaded files will be stored.
# If not specified, it will be set to the document root
# (e.g. /usr/local/etc/httpd/htdocs) automatically, and
# the new files will be written directly to the location
# specified in the URL.  Be careful!  Old files may be
# overwritten if you do this.  You should also look at the
# $DIR_PERM and $FILE_PERM variables and change them if 
# the defaults are not to your liking.
#
# The upload directory must be writable by the "nobody" user or
# the upload script will fail.
#
# This file requires the CGI::Carp module, which is part of the
# CGI.pm package:
# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html

# WARNING: Do not use version 1.1 of this script.  It contained a security
# hole that allowed the script to overwrite files outside the upload
# directory if the server was improperly configured.

# AUTHOR: Lincoln D. Stein, lstein@genome.wi.mit.edu
#         Please contact me only if you're EXTREMELY desperate.
# Copyright 1996, Lincoln D. Stein, all rights reserved
# Version 1.2, March 14, 1997

# Uncomment the $UPLOADS line if you want to force all files to
# be uploaded to a special staging area
$UPLOADS='/usr/tmp/web_incoming';

# These variables control the permissions on newly-created files and directories.
# Change then to suit your preferences.
$DIR_PERM = 0775;		# permissions for created directories (drwxrwxr-x)
$FILE_PERM = 0664;		# permissions for created files (-rw-rw-r--)

# ------------------------- no user serviceable parts below -------------------

use CGI::Carp;

$ENV{PATH}='/bin:/usr/bin';

$CRLF = "\015\012";
%EXP = (200=>'OK',
	400=>'Bad Request',
	500=>'Internal Error');

$ENV{'REQUEST_METHOD'} eq 'PUT' || 
    user_error("Request method must be PUT to call this script!\n");

$DATA_LENGTH = $ENV{'CONTENT_LENGTH'};

# untaint path and path_translated to avoid unwelcome surprises.
$PATH = untaint ($ENV{PATH_INFO});
$PATH_TRANSLATED = untaint ($ENV{PATH_TRANSLATED});
$DOCUMENT_ROOT = untaint ($ENV{DOCUMENT_ROOT});

# Figure out where the document is to be stored.  If no $UPLOADS
# root is defined, or if the path contains the special "~" character,
# then use the path translated.  Otherwise prepend the upload directory
# to the document.
if (!$UPLOADS || $PATH=~/~/) {
    $path = $PATH_TRANSLATED;
} elsif (substr($UPLOADS,0,1) eq '/') {
    $path = "$UPLOADS$PATH";
} else {
    $path = "$DOCUMENT_ROOT/$UPLOADS$PATH";
}

create_directories($path);

write_file($path,$DATA_LENGTH) ||
    error_exit("Couldn't write the file '$path': $!\n");

ok_exit("Document '$path' successfully created.\n");

sub create_directories {
    my $path = shift;
    my ($junk,@dir) = split('/',$path);
    pop @dir;
    my ($dir);
    foreach (@dir) {
	$dir .= "/$_";
	next if -d $dir;
	if (-e _) {
	    user_error("Bad path: '$dir' isn't a directory.\n");
	} else {
	    mkdir($dir,$DIR_PERM) || die error_exit("Couldn't create directory '$dir': $!\n");
	}
    }
    1;
}

sub write_file {
    my $path = shift;
    my $length = shift;
    open (FILE,">$path") || 
	error_exit("Couldn't open '$path' for writing: $!\n");
    chmod $FILE_PERM,$path;
    while ($length > 0) {
	my $bytes_to_read = 1024 < $length ? 1024 : $length;
	my $data;
	my $bytes_read = read(STDIN,$data,$bytes_to_read);
	if (!defined($bytes_read)) {
	    error_exit("An error occurred while reading input document: $!\n");
	}
	$length -= $bytes_read;
	print FILE $data;
    }
    close FILE;
}

# untaint path names
sub untaint {
    my $path = shift;
    user_error("path cannot contain metacharacters") if $path=~/[\n|<>&!;\'\"]/;

    # extract only legal alphanumerics from the path
    $path =~ m!(/[a-zA-Z/0-9._~\-]+)!;
    $path = $1;

    user_error("path cannot contain relative directories") 
	if $path=~m!\.\.!;

    return $path;
}

sub error_exit {
    my $msg = shift;
    do_exit(500,$msg);
}

sub user_error {
    my $msg = shift;
    do_exit(400,$msg);
}

sub ok_exit {
    my $msg = shift;
    do_exit(200,$msg);
}

sub do_exit {
    my($code,$msg) = @_;
    print "HTTP/1.0 $code $EXP{$code}$CRLF";
    print "Content-type: text/html",$CRLF,$CRLF;
    print <<EOF;
<H3>$msg</H3>
EOF
    ;
    exit 0;
}