#!/usr/bin/perl 
##############################################################################
$VERSION='getit.pl v1.21'; # Feb 3 97 dale@bewley.net
# v1.1 Dec 19 96, v1.0 Sep 96 
#----------------------------------------------------------------------------#
# Select files from a specified sub dir. Instead of just opening in browser
# users may download, view or mail it to themselves.
#
# this program is not finished! be careful!
#
# Copyright (C) 1996 Dale Bewley <dale@bewley.net>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
##############################################################################

#- User Config --------------------------------------------------------------#
# your webserver's base URL
$HTTP_SERVER = "http://www.bewley.net/"; # note trailing slash /. Keep it!

# Todo: maybe make this an array and call the program with d=0 or d=1 etc to
# select different file areas. Will have revisit what I'm doing with doc_root.
# set this to the dir you want browsed
$QUEUE_DIR = "/httpd/htdocs/bewley/perl"; # users may not go above here

# set this to your web server's document root. ie /usr/local/etc/httpd/htdocs/
$DOC_ROOT = "/httpd/htdocs/bewley/"; # will strip this from queue_dir later

# program used to send mail on your system
$MAILPROG="/usr/lib/sendmail -oi -t";

$TAR ='/bin/tar';
$GZIP='/bin/gzip';
$ZIP ='/usr/bin/zip';

# ignore this
$AUTHOR = 'dale@bewley.net'; # goes in html head and email

# ignore this
$MIME_TYPES="/extra/WWW/httpd.1.4.2/conf/mime.types"; # unused so far...

# ignore this
$BOUNDARY="--start-new-page-here--"; # leave alone. don't change!
# that's it. you're done. run it!
#----------------------------------------------------------------------------#


#- Main ---------------------------------------------------------------------#
$|=1; # you'll have some odd problems without this
use CGI;

# list dirs in queue_dir, get names of all queued files in selected subdir &
# list them for selection, then read/download that file

if (! ($ENV{'CONTENT_LENGTH'} || $ENV{'QUERY_STRING'})) {
    # no arguments yet. show first default listing
    &listFiles($QUEUE_DIR);
} else {
    # we have submitted a file or directory name
    $FORM = new CGI;

    @files = $FORM->param('submission');

    foreach $file (@files) {
	# restore full path
	$file =~ s/^(.*)/$DOC_ROOT$1/;
	# avoid ../ and ; also don't show an .files like .htpasswd or such
	# fix this for .files
	if (($file =~ /\.\.|;/) || ($file !~ m#^$QUEUE_DIR[^\.]#o)) {
	    # avoid stuff like ../../
	    &error("500 Internal Server Error", 
	       "Can't open file \'$file\'. No dot dots.");
        }

	if (-d $file) {
	    # for a directory, just list the files in it
	    &listFiles($file) && exit;
        }

	# branch based on the submit button text
	if ($FORM->param(submit) =~ /Get|Down|Save/) {
	    # I'm guessing you just want to DOWNLOAD the file?
#	    if ($FORM->param(tar)) {
	#	($FORM->param(gzip) && &tarIt(@files, gzip)) || &tarIt(@files);
	 #   } else {
		&downloadIt($file);
	  #  }
	} elsif ($FORM->param(submit) =~ /Mail/) {
	    # I'm guessing you just want to MAIL the file?
	    &mailIt($file);
	} elsif ($FORM->param(submit) =~ /View|Show/) {
	    # I'm guessing you just want to SEE the file?
	    &showIt($file);
	}
    }
}
#----------------------------------------------------------------------------#


#- Read names from tmp ------------------------------------------------------#
sub listFiles {
    my($query) = new CGI;
    my($queue_dir) = shift(@_);
    my($DIR)=$queue_dir;
    $DIR =~ s/^$DOC_ROOT(.*)/$1/;
    my($title) = "File listing for $HTTP_SERVER$DIR";
    my($fileList);


    print $query->header;
    print $query->start_html(-title=>$title,
		-author=>$AUTHOR);

    print "<H1>$title</H1>\n<HR>\n";

    if(@fileList = &getFileList($queue_dir)) {

	print $query->startform;
	# I plan to change this to a multi select box
	print $query->popup_menu('submission',
			[@fileList]);
	print "<BR>\n";
	print "<em>These check boxes don't work for mail yet!</em><br>\n";
	print $query->checkbox(-name=>'tar',-label=>'Tar');
	print $query->checkbox(-name=>'gzip',-label=>'Gzip');
	print $query->checkbox(-name=>'zip',-label=>'Zip');
	print $query->checkbox(-name=>'uuencode',-label=>'Uuencode');
	print "<BR>\n";
	
	print $query->submit(-name=>'submit',
				-value=>'View It');
	print "\n", $query->submit(-name=>'submit',
				-value=>'Get It!');

		print "\n", $query->submit(-name=>'submit',
				-value=>'Mail It!');
		print $query->textfield(-name=>'recipient', 
				        -default=>'Enter Email');
		print "\n", $query->endform;
	} else {
		print "<H1>No files in this directory</H1>\n";
	}

	print "\n", $query->end_html;
}
#----------------------------------------------------------------------------#


#- Send the file ------------------------------------------------------------#
sub showIt {
    # add options to read and print files that are out of the doc_root.

    # once multi select and tar options are added this may be a little clumsy
    # you will only be able to view one file at a time.
    # hrmm... good enough for now.
    my($file)=shift;
    $url = $HTTP_SERVER;
    $file =~ s/^$DOC_ROOT//;
    $url .= $file;
    
    print $FORM->redirect($url);
}
#----------------------------------------------------------------------------#


#----------------------------------------------------------------------------#
sub downloadIt {
    my($file) = shift;
    my($description) = shift;

    my($filename)=$file;
    $filename =~ s/^$DOC_ROOT(.*)/$1/;
    my($title) = "$HTTP_SERVER$filename";
#    $title |= $file;
    $description |= $title;
    print "Content-type: multipart/x-mixed-replace;boundary=$BOUNDARY\n\n";

    print "--$BOUNDARY\n";
    #  account for different MIME types? or print location?
    # print "Content-type: application/x-perl\n" if ($file =~ /\.pl$/);
    print $FORM->header();
    print $FORM->start_html(-title=>$title,
		-author=>$AUTHOR);


    print "<H2>Downloading $title</H2>\n<HR>\n";
    print "Please choose 'Save-As' and select a location to save the file.";
    print "\n<HR>\n";
    print "<font size=-1><a href=\"http://www.bewley.net/perl/\">$VERSION";
    print "</A></font>\n";
    print "$BOUNDARY\n";
    print "Content-type: application/x-download\n";
    print "Content-Disposition: attachment; filename=$file";
    if ($FORM->param('tar')) { print ".tar"; }
    if ($FORM->param('gzip')) { print ".gz"; }
    if ($FORM->param('zip')) { print ".zip"; }
    print "\n";
    print "Content-Description: $description\n\n";

    # this stuff isn't done yet.
    if ($FORM->param('tar')) {
	exec($TAR, " -cf", $FORM->param('gzip') ? 'z':'', "f - $file"); 
	exit; # well, exec will exit for you anyway.
    }
    if ($FORM->param('gzip')) {
	exec($GZIP, "-c", $file);
	exit; # well, exec will exit for you anyway.
    }
    if ($FORM->param('zip')) {
	exec($ZIP, "-l -", $file);
	exit; # well, exec will exit for you anyway.
    }

    open(FILE, "$file") || &error("500 Internal Server Error", 
		      "Cannot open $file $!");
    print <FILE>;
    close FILE;
}
#----------------------------------------------------------------------------#


#- Read submissions in QUEUE_DIR --------------------------------------------#
sub getFileList {
        my($dir) = shift @_;
        my(@fileList);
	
	# don't open a symlink!!! that could be bad.
	return "Nice try, but we don't allow symlinks here!" if (-l $dir); 

	# read in files while ignoring symlinks
	opendir(DIR,"$dir") || return;
	foreach $_ (grep(! /^\.|~/, readdir(DIR)))  {
	        $dir =~ s/^$DOC_ROOT(.*)/$1/o;
		push(@fileList,"$dir/$_") unless (-l "$DOC_ROOT$dir/$_");
#		push(@fileList,("$dir/" . $_)) unless (-l "$dir/$DOC_ROOT$_");
	}
        close(DIR);

	return @fileList;
}
#----------------------------------------------------------------------------#


#----------------------------------------------------------------------------#
sub mailIt {
        # do we have an email address?
	if (! $FORM->param(recipient)) {
	print "Content-type: multipart/x-mixed-replace;boundary=$BOUNDARY\n\n";
	print "--$BOUNDARY\n";
	    print $query->header;
	    print $query->start_html(-title=>'Enter email address!',
			-author=>$AUTHOR);

	    print $FORM->startform;
	    print "Enter your Email address:";
	    print $FORM->textfield('recipient'), "\n";
	    print $FORM->hidden(-name=>'submission',
				      -value=>$file), "\n";
	    print $FORM->submit(-name=>'submit',
				      -value=>'Mail It!'), "\n";
	    print $FORM->endform, "\n";
	    print $FORM->end_html;
	    return;
	}

	my($file)=shift;

	print "Content-type: multipart/x-mixed-replace;boundary=$BOUNDARY\n\n";
	print "--$BOUNDARY\n";
	print $FORM->header();
	print $FORM->start_html(-title=>$title,
			-author=>$AUTHOR);
	print "<H1>Mailing $file</H1>\n<HR>\n";
	print "<H3>$file</H3>\n";
	print "<HR>\n";
	print "<a href=\"http://www.bewley.net/perl/\">$VERSION</A>\n";

        open(MAIL, "|$MAILPROG") ||
                &error("500 Internal Server Error", "Can't open $MAILPROG $!");
        print MAIL "MIME-Version: 1.0 ($VERSION)\n";
        $recipient = $FORM->param(recipient);
        print MAIL "To: $recipient\n";
        print MAIL "From: $AUTHOR\n";
        print MAIL "Subject: $file\n";
        print MAIL "Content-type: multipart/mixed;\n\tboundary=$BOUNDARY\n\n";

        print MAIL "--$BOUNDARY\n";
        print MAIL "Content-type: text/plain; charset=US-ASCII\n\n";
        print MAIL "\nHere is the file you requested from\n";
	print MAIL "$ENV{HTTP_REFERER}\n\n";

	# just junk 
	foreach (sort keys %ENV) {
		print MAIL "$_ = $ENV{$_}\n";
	}

        print MAIL "--$BOUNDARY\n";
        print MAIL "Content-type: text/plain; charset=US-ASCII\n\n";
      #  print MAIL "Content-Disposition: attachment; filename=dale-perl.tar.gz\n ";
      #  print MAIL "Content-Description: Dale Bewley's perl archive\n\n";
	# restore full path
	open(FILE, "$file") || 
                &error("500 Internal Server Error", "Can't open $file $!");
	print MAIL <FILE>;
        close MAIL, FILE;
	print $query->header;
	print $query->start_html(-title=>$title,
			-author=>$AUTHOR);



}
#----------------------------------------------------------------------------#


#- Send error to browser and admin ------------------------------------------#
sub error {
    # this could help you catch hack attempts
    my($status,$msg)=@_;
    print $FORM->header(-type=>'text/html'
		-status=>$status);
    print $FORM->start_html(-title=>$status,
		-author=>$AUTHOR);
    print "<H1>$status</H1>\n";
    print $msg;
    print "<HR>\n<P>Please direct questions to ";
    print "<a href=\"mailto:$AUTHOR\">$AUTHOR</A>.";
    print $FORM->end_html;

    open (MAIL, "|$MAILPROG") || die "Can't open $MAILPROG $! ";
    print MAIL "To: $WEBMASTER,$AUTHOR\n";
    print MAIL "From: $VERSION - <", $FORM->param('email'), ">\n";
    print MAIL "Subject: $VERSION - $status\n\n";
    print MAIL "$msg\n\n";

    my(@values,$key);

    foreach $key ($FORM->param) {
	print MAIL "$key -> ";
	@values = $FORM->param($key);
	print MAIL join(", ",@values),"\n";
    }

    foreach (sort keys %ENV) {
	print MAIL "$_ = $ENV{$_}\n";
    }

    close MAIL;
    exit;
}
#----------------------------------------------------------------------------#

__END__