#!/usr/bin/perl ############################################################################ # # WebSaver.cgi -- Brad Fitzpatrick # ############################################################################ # where the websaver files will live on the server. an absolute or relative # path both work here. ending slashes don't matter. example include: # /home/billybob/ws_data/ # ../ws_data/ # ws_data/ (not recommended to have your data directory # be in your document root, otherwise people can # read if over the web.) # chomp($username = `whoami`); $DATA_DIR = "/www/homes/$username/ws_data/"; ############################################################################ $DATA_DIR =~ s!/$!!; # remove trailing slash # show the tests page if they ask for the page in their web browser if ($ENV{'REQUEST_METHOD'} ne "POST") { print "Content-type: text/html\n\n"; print "Websaver Server\n"; print "

Websaver Server

\n"; print "If you can see this, the Websaver server is at least mostly working. Let's check some additional things...\n"; print "\n"; print "If any of the above tests fail, the Websaver classes will probably not work. If they all pass, you're good to go."; print "\n"; exit; } # do the actual work, if this is a POST request print "Content-type: text/plain\n\n"; $req = {}; # request $res = {}; # response $fileinfo = {} # metainfo about the file &get_form_data($req); # load the request $res->{'success'} = "OK"; if ($req->{'mode'} eq "readfile") { &mode_readfile($req, $res, $fileinfo); } elsif ($req->{'mode'} eq "writefile") { &mode_writefile($req, $res, $fileinfo); } elsif ($req->{'mode'} eq "listfiles") { &mode_listfiles($req, $res, $fileinfo); } else { $res->{'success'} = "FAIL"; $res->{'errmsg'} = "Unknown mode"; } # create the response $response = ""; foreach my $k (keys %{$res}) { $response .= "&" if $response; $response .= &eurl($k) . "=" . &eurl($res->{$k}); } print $response; ###################[ Mode functions ]####################################### sub mode_readfile { my ($req, $res, $fileinfo) = @_; return if (&bad_file($req, $res, $fileinfo)); &load_metainfo($req, $fileinfo); if ($fileinfo->{'password'} && $fileinfo->{'publicread'}==0 && $fileinfo->{'password'} ne $req->{'password'}) { $res->{'success'} = "FAIL"; $res->{'errmsg'} = "File is not public and incorrect password was given"; return; } open (FILE, "$fileinfo->{'realfile'}"); $res->{'streamdata'} = join('', ); close FILE; } sub mode_writefile { my ($req, $res, $fileinfo) = @_; return if (&bad_file($req, $res)); &load_metainfo($req, $fileinfo); if ($fileinfo->{'password'} && $fileinfo->{'password'} ne $req->{'password'}) { $res->{'success'} = "FAIL"; $res->{'errmsg'} = "File is password protected and incorrect password was given"; return; } open (FILE, ">$fileinfo->{'realfile'}"); print FILE $req->{'streamdata'}; close FILE; open (META, ">$fileinfo->{'metafile'}"); print META "password: $req->{'password'}\n" if ($req->{'password'}); print META "publicread: $req->{'publicread'}\n" if ($req->{'publicread'}); close META; } sub mode_listfiles { my ($req, $res, $fileinfo) = @_; return if (&bad_file($req, $res)); # this will work if directory is blank or specified: my $dir = "$DATA_DIR/$req->{'directory'}"; opendir (DIR, $dir); # get the list of files (those ending in .d) and remove the .d my @files = map { s/\.d$//; $_; } grep { /\.d$/ } readdir(DIR); closedir (DIR); # sort the files, without regard to case @files = sort { lc($a) cmp lc($b) } @files; $res->{'filecount'} = scalar(@files); for (my $i=0; $i<$res->{'filecount'}; $i++) { $res->{"f$i"} = $files[$i]; } } ################################[ Functions ]############################### # returns true if the filename is bad sub bad_file { my ($req, $res) = @_; # directory cannot contain weird characters if ($req->{'directory'} && $req->{'directory'} =~ /\W/) { $res->{'success'} = "FAIL"; $res->{'errmsg'} = "Invalid characters in directory name"; return 1; } # if getting a directory listing, we don't care about the filename if ($req->{'mode'} eq "listfiles") { return 0; } # filename can contain most weird characters, but not all if ($req->{'filename'} !~ /^[\w\.\- \,\?\!\(\)]+$/) { $res->{'success'} = "FAIL"; $res->{'errmsg'} = "Invalid File Name"; return 1; } # filename cannot consist entirely of dots (don't want to mangle . or ..) if ($req->{'filename'} =~ /^\.+$/ || $req->{'filename'} =~ /^\s+/ || # no whitespace at beginning $req->{'filename'} =~ /\s+$/) # .... or end { $res->{'success'} = "FAIL"; $res->{'errmsg'} = "Invalid File Name"; return 1; } return 0; } # loads meta info about a file # precondition: the request filename is assumed to be good. make sure bad_file # is called first, and return before you get here if it's bad sub load_metainfo { my ($req, $fileinfo) = @_; # directory? if ($req->{'directory'}) { my $dir = "$DATA_DIR/$req->{'directory'}"; $fileinfo->{'realfile'} = "$dir/$req->{'filename'}.d"; # make the directory if it doesn't exist unless (-d $dir) { mkdir $dir, 0755; } } else { $fileinfo->{'realfile'} = "$DATA_DIR/$req->{'filename'}.d"; } $fileinfo->{'metafile'} = "$fileinfo->{'realfile'}.meta"; return unless (-e $fileinfo->{'metafile'}); open (META, $fileinfo->{'metafile'}); while (my $l = ) { $l =~ s/^\s+//; $l =~ s/\s+$//; my ($key, $value) = split(/\s*:\s*/, $l); $fileinfo->{$key} = $value; } close META; } ############################[ Utility Functions ]########################### # encode a URL sub eurl { my $a = $_[0]; $a =~ s/([^a-zA-Z0-9_\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg; $a =~ tr/ /+/; return $a; } # load get/post form data into given hashref sub get_form_data { my ($hashref) = shift; my $buffer; if ($ENV{'REQUEST_METHOD'} eq 'POST') { read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); } else { $buffer = $ENV{'QUERY_STRING'} || $ENV{'REDIRECT_QUERY_STRING'}; } # Split the name-value pairs my $pair; my @pairs = split(/&/, $buffer); my ($name, $value); foreach $pair (@pairs) { ($name, $value) = split(/=/, $pair); $value =~ tr/+/ /; $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $name =~ tr/+/ /; $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $hashref->{$name} .= $hashref->{$name} ? "\0$value" : $value; } }