loncom/publisher/lonupload.pm - view

File: [LON-CAPA] / loncom / publisher / lonupload.pm
Revision 1.24: download - view: text, annotated - select for diffs
Sat Nov 8 11:13:50 2003 UTC (20 years, 6 months ago) by albertel
Branches: MAIN
CVS tags: version_1_1_X, version_1_1_3, version_1_1_2, version_1_1_1, version_1_1_0, version_1_0_99_3, version_1_0_99_2, version_1_0_99_1, version_1_0_99, HEAD

-more xhtmlize

1: 2: # The LearningOnline Network with CAPA 3: # Handler to upload files into construction space 4: # 5: # $Id: lonupload.pm,v 1.24 2003/11/08 11:13:50 albertel Exp $ 6: # 7: # Copyright Michigan State University Board of Trustees 8: # 9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 10: # 11: # LON-CAPA is free software; you can redistribute it and/or modify 12: # it under the terms of the GNU General Public License as published by 13: # the Free Software Foundation; either version 2 of the License, or 14: # (at your option) any later version. 15: # 16: # LON-CAPA is distributed in the hope that it will be useful, 17: # but WITHOUT ANY WARRANTY; without even the implied warranty of 18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19: # GNU General Public License for more details. 20: # 21: # You should have received a copy of the GNU General Public License 22: # along with LON-CAPA; if not, write to the Free Software 23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 24: # 25: # /home/httpd/html/adm/gpl.txt 26: # 27: # http://www.lon-capa.org/ 28: # 29: ### 30: 31: package Apache::lonupload; 32: 33: use strict; 34: use Apache::File; 35: use File::Copy; 36: use File::Basename; 37: use Apache::Constants qw(:common :http :methods); 38: use Apache::loncacc; 39: use Apache::loncommon(); 40: use Apache::Log(); 41: use Apache::lonnet; 42: use HTML::Entities(); 43: use Apache::lonlocal; 44: 45: my $DEBUG=0; 46: 47: sub Debug { 48: 49: # Marshall the parameters. 50: 51: my $r = shift; 52: my $log = $r->log; 53: my $message = shift; 54: 55: # Put out the indicated message butonly if DEBUG is false. 56: 57: if ($DEBUG) { 58: $log->debug($message); 59: } 60: } 61: 62: sub upfile_store { 63: my $r=shift; 64: 65: my $fname=$ENV{'form.upfile.filename'}; 66: $fname=~s/\W//g; 67: 68: chomp($ENV{'form.upfile'}); 69: 70: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. 71: '_upload_'.$fname.'_'.time.'_'.$$; 72: { 73: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons'). 74: '/tmp/'.$datatoken.'.tmp'); 75: print $fh $ENV{'form.upfile'}; 76: } 77: return $datatoken; 78: } 79: 80: 81: sub phaseone { 82: my ($r,$fn,$uname,$udom)=@_; 83: $ENV{'form.upfile.filename'}=~s/\\/\//g; 84: $ENV{'form.upfile.filename'}=~s/^.*\/([^\/]+)$/$1/; 85: if ($ENV{'form.upfile.filename'}) { 86: $fn=~s/\/[^\/]+$//; 87: $fn=~s/([^\/])$/$1\//; 88: $fn.=$ENV{'form.upfile.filename'}; 89: $fn=~s/^\///; 90: $fn=~s/(\/)+/\//g; 91: 92: # Fn is the full path to the destination filename. 93: # 94: 95: &Debug($r, "Filename for upload: $fn"); 96: if (($fn) && ($fn!~/\/$/)) { 97: $r->print('<form action="/adm/upload" method="post">'. 98: '<input type="hidden" name="phase" value="two" />'. 99: '<input type="hidden" name="datatoken" value="'. 100: &upfile_store.'" />'. 101: '<input type="hidden" name="uploaduname" value="'.$uname. 102: '" />'.&mt('Store uploaded file as '). 103: "<tt>/priv/$uname/</tt>". 104: '<input type="text" size="50" name="filename" value="'.$fn. 105: '" /><br />'. 106: '<input type="submit" value="'.&mt('Store').'" /></form>'); 107: # Check for bad extension and warn user 108: if ($fn=~/\.(\w+)$/ && 109: (&Apache::loncommon::fileembstyle($1) eq 'hdn')) { 110: $r->print('<font color="red">'.&mt('The extension on this file,'). 111: ' "'.$1.'"'.&mt(', is reserved internally by LON-CAPA.'). 112: ' <br />'.&mt('Please change the extension.').'</font>'); 113: } elsif($fn=~/\.(\w+)$/ && 114: !defined(&Apache::loncommon::fileembstyle($1))) { 115: $r->print('<font color="red">'.&mt('The extension on this file,'). 116: ' "'.$1.'"'.&mt(', is not recognized by LON-CAPA.'). 117: ' <br />'.&mt('Please change the extension.'). 118: '</font>'); 119: } 120: } else { 121: $r->print('<font color="red">'.&mt('Illegal filename.').'</font>'); 122: } 123: } else { 124: $r->print('<font color="red">'.&mt('No upload file specified.').'</font>'); 125: } 126: } 127: 128: sub phasetwo { 129: my ($r,$tfn,$uname,$udom)=@_; 130: my $fn='/priv/'.$uname.'/'.$tfn; 131: $fn=~s/\/+/\//g; 132: &Debug($r, "Filename is ".$tfn); 133: if ($tfn) { 134: &Debug($r, "Filename for tfn = ".$tfn); 135: my $target='/home/'.$uname.'/public_html'.$tfn; 136: &Debug($r, "target -> ".$target); 137: # target is the full filesystem path of the destination file. 138: my $base = &File::Basename::basename($fn); 139: my $path = &File::Basename::dirname($fn); 140: $base = &HTML::Entities::encode($base); 141: my $url = $path."/".$base; 142: &Debug($r, "URL is now ".$url); 143: my $datatoken=$ENV{'form.datatoken'}; 144: if (($fn) && ($datatoken)) { 145: if ((-e $target) && ($ENV{'form.override'} ne 'Yes')) { 146: $r->print('<form action="/adm/upload" method="post">'. 147: &mt('File').' <tt>'.$fn.'</tt> '. 148: &mt('exists. Overwrite?').' '. 149: '<input type="hidden" name="phase" value="two" />'. 150: '<input type="hidden" name="filename" value="'."$url".'" />'. 151: '<input type="hidden" name="datatoken" value="'.$datatoken.'" />'. 152: '<input type="submit" name="override" value="'.&mt('Yes').'" /></form>'); 153: } else { 154: my $source=$r->dir_config('lonDaemons').'/tmp/'.$datatoken.'.tmp'; 155: # Check for bad extension and disallow upload 156: if ($fn=~/\.(\w+)$/ && 157: (&Apache::loncommon::fileembstyle($1) eq 'hdn')) { 158: $r->print(&mt('File').' <tt>'.$fn.'</tt> '. 159: &mt('could not be copied.').'<br />'. 160: '<font color="red">'. 161: &mt('The extension on this file is reserved internally by LON-CAPA.'). 162: '</font>'); 163: $r->print('<br /><font size=+2><a href="'.$path.'">'. 164: &mt('Back to Directory').'</a></font>'); 165: } elsif ($fn=~/\.(\w+)$/ && 166: !defined(&Apache::loncommon::fileembstyle($1))) { 167: $r->print(&mt('File').' <tt>'.$fn.'</tt> '. 168: &mt('could not be copied.').'<br />'. 169: '<font color="red">'. 170: &mt('The extension on this file is not recognized by LON-CAPA.'). 171: '</font>'); 172: $r->print('<br /><font size="+2"><a href="'.$path.'">'. 173: &mt('Back to Directory').'</a></font>'); 174: } elsif (-d $target) { 175: $r->print('File <tt>'.$fn.'</tt> could not be copied.<br />'. 176: '<font color="red">'. 177: &mt('The target is an existing directory.'). 178: '</font><br />'); 179: $r->print('<font size="+2"><a href="'.$path.'">'. 180: &mt('Back to Directory').'</a></font>'); 181: } elsif (copy($source,$target)) { 182: chmod(0660, $target); # Set permissions to rw-rw---. 183: $r->print(&mt('File copied.')); 184: $r->print('<br /><font size="+2"><a href="'.$url.'">'. 185: &mt('View file').'</a></font>'); 186: $r->print('<br /><font size="+2"><a href="'.$path.'">'. 187: &mt('Back to Directory').'</a></font><br />'); 188: } else { 189: $r->print('Failed to copy: '.$!); 190: $r->print('<br /><font size="+2"><a href="'.$path.'">'. 191: &mt('Back to Directory').'</a></font>'); 192: } 193: } 194: } else { 195: $r->print('<font size="+1" color="red">'. 196: &mt('Please use browser "Back" button and pick a filename'). 197: '</font><br />'); 198: } 199: } else { 200: $r->print('<font size=+1 color=red>'. 201: &mt('Please use browser "Back" button and pick a filename'). 202: '</font><br />>'); 203: } 204: } 205: 206: # ---------------------------------------------------------------- Main Handler 207: sub handler { 208: 209: my $r=shift; 210: 211: my $uname; 212: my $udom; 213: # 214: # phase two: re-attach user 215: # 216: if ($ENV{'form.uploaduname'}) { 217: $ENV{'form.filename'}='/priv/'.$ENV{'form.uploaduname'}.'/'. 218: $ENV{'form.filename'}; 219: } 220: # 221: 222: ($uname,$udom)= 223: &Apache::loncacc::constructaccess($ENV{'form.filename'}, 224: $r->dir_config('lonDefDomain')); 225: unless (($uname) && ($udom)) { 226: $r->log_reason($uname.' at '.$udom. 227: ' trying to publish file '.$ENV{'form.filename'}. 228: ' - not authorized', 229: $r->filename); 230: return HTTP_NOT_ACCEPTABLE; 231: } 232: 233: my $fn; 234: if ($ENV{'form.filename'}) { 235: $fn=$ENV{'form.filename'}; 236: $fn=~s/^http\:\/\/[^\/]+\///; 237: $fn=~s/^\///; 238: $fn=~s/(\~|priv\/)(\w+)//; 239: $fn=~s/\/+/\//g; 240: } else { 241: $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. 242: ' unspecified filename for upload', $r->filename); 243: return HTTP_NOT_FOUND; 244: } 245: 246: # ----------------------------------------------------------- Start page output 247: 248: 249: &Apache::loncommon::content_type($r,'text/html'); 250: $r->send_http_header; 251: 252: $r->print('<html><head><title>LON-CAPA Construction Space</title></head>'); 253: 254: $r->print(&Apache::loncommon::bodytag('Upload file to Construction Space')); 255: 256: if (($uname ne $ENV{'user.name'}) || ($udom ne $ENV{'user.domain'})) { 257: $r->print('<h3><font color=red>'.&mt('Co-Author').': '.$uname. 258: &mt(' at ').$udom.'</font></h3>'); 259: } 260: 261: if ($ENV{'form.phase'} eq 'two') { 262: &phasetwo($r,$fn,$uname,$udom); 263: } else { 264: &phaseone($r,$fn,$uname,$udom); 265: } 266: 267: $r->print('</body></html>'); 268: return OK; 269: } 270: 271: 1; 272: __END__ 273: 274: =head1 NAME 275: 276: Apache::lonupload - upload files into construction space 277: 278: =head1 SYNOPSIS 279: 280: Invoked by /etc/httpd/conf/srm.conf: 281: 282: <Location /adm/upload> 283: PerlAccessHandler Apache::lonacc 284: SetHandler perl-script 285: PerlHandler Apache::lonupload 286: ErrorDocument 403 /adm/login 287: ErrorDocument 404 /adm/notfound.html 288: ErrorDocument 406 /adm/unauthorized.html 289: ErrorDocument 500 /adm/errorhandler 290: </Location> 291: 292: =head1 INTRODUCTION 293: 294: This module uploads a file sitting on a client computer into 295: library server construction space. 296: 297: This is part of the LearningOnline Network with CAPA project 298: described at http://www.lon-capa.org. 299: 300: =head1 HANDLER SUBROUTINE 301: 302: This routine is called by Apache and mod_perl. 303: 304: =over 4 305: 306: =item * 307: 308: Initialize variables 309: 310: =item * 311: 312: Start page output 313: 314: =item * 315: 316: output relevant interface phase (phaseone or phasetwo) 317: 318: =item * 319: 320: (phase one is to specify upload file; phase two is to handle conditions 321: subsequent to specification--like overwriting an existing file) 322: 323: =back 324: 325: =head1 OTHER SUBROUTINES 326: 327: =over 4 328: 329: =item * 330: 331: phaseone() : Interface for specifying file to upload. 332: 333: =item * 334: 335: phasetwo() : Interface for handling post-conditions about uploading (such 336: as overwriting an existing file). 337: 338: =item * 339: 340: upfile_store() : Store contents of uploaded file into temporary space. Invoked 341: by phaseone subroutine. 342: 343: =back 344: 345: =cut