# The LearningOnline Network with CAPA
# Handler to upload files into construction space
#
# $Id: lonupload.pm,v 1.69 2019/03/04 19:54:35 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA 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.
#
# LON-CAPA 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 LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
###
=head1 NAME
Apache::lonupload - upload files into construction space
=head1 SYNOPSIS
Invoked by /etc/httpd/conf/srm.conf:
PerlAccessHandler Apache::lonacc
SetHandler perl-script
PerlHandler Apache::lonupload
ErrorDocument 403 /adm/login
ErrorDocument 404 /adm/notfound.html
ErrorDocument 406 /adm/unauthorized.html
ErrorDocument 500 /adm/errorhandler
=head1 INTRODUCTION
This module uploads a file sitting on a client computer into
library server construction space.
This is part of the LearningOnline Network with CAPA project
described at http://www.lon-capa.org.
=head1 HANDLER SUBROUTINE
This routine is called by Apache and mod_perl.
=over 4
=item *
Initialize variables
=item *
Start page output
=item *
output relevant interface phase (phaseone, phasetwo, phasethree or phasefour)
=item *
(phase one is to specify upload file; phase two is to handle conditions
subsequent to specification--like overwriting an existing file; phase three
is to handle processing of secondary uploads - of embedded objects in an
html file).
=back
=head1 OTHER SUBROUTINES
=over
=item phaseone()
Interface for specifying file to upload.
=item phasetwo()
Interface for handling post-conditions about uploading (such
as overwriting an existing file).
=item phasethree()
Interface for handling secondary uploads of embedded objects
in an html file.
=item phasefour()
Interface for handling optional renaming of links to embedded
objects.
=item upfile_store()
Store contents of uploaded file into temporary space. Invoked
by phaseone subroutine.
=item check_extension()
Checks if filename extension is permitted and checks type
of file - if html file, calls parser to check for embedded objects.
Invoked by phasetwo subroutine.
=back
=cut
package Apache::lonupload;
use strict;
use Apache::File;
use File::Copy;
use File::Basename;
use Apache::Constants qw(:common :http :methods);
use Apache::loncommon();
use Apache::lonnet;
use HTML::Entities();
use Apache::lonlocal;
use Apache::lonnet;
use LONCAPA qw(:DEFAULT :match);
my $DEBUG=0;
sub Debug {
# Put out the indicated message but only if DEBUG is true.
if ($DEBUG) {
my ($r,$message) = @_;
$r->log_reason($message);
}
}
sub upfile_store {
my $r=shift;
my $fname=$env{'form.upfile.filename'};
$fname=~s/\W//g;
chomp($env{'form.upfile'});
my $datatoken;
if (($env{'user.name'} =~ /^$match_username$/) && ($env{'user.domain'} =~ /^$match_domain$/)) {
$datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
'_upload_'.$fname.'_'.time.'_'.$$;
}
return if ($datatoken eq '');
{
my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
'/tmp/'.$datatoken.'.tmp');
print $fh $env{'form.upfile'};
}
return $datatoken;
}
sub phaseone {
my ($r,$fn,$mode,$uname,$udom)=@_;
my $action = '/adm/upload';
if ($mode eq 'testbank') {
$action = '/adm/testbank';
} elsif ($mode eq 'imsimport') {
$action = '/adm/imsimport';
}
# Check for file to be uploaded
$env{'form.upfile.filename'}=~s/\\/\//g;
$env{'form.upfile.filename'}=~s/^.*\/([^\/]+)$/$1/;
$env{'form.upfile.filename'}=~s/(\s+$|^\s+)//g;
if (!$env{'form.upfile.filename'}) {
$r->print('
'.&mt('No upload file specified.').'
'.
&earlyout($fn,$uname,$udom));
return;
}
# Append the name of the uploaded file
$fn.=$env{'form.upfile.filename'};
$fn=~s/(\/)+/\//g;
# Check for illegal filename
&Debug($r, "Filename for upload: $fn");
if (!(($fn) && ($fn!~/\/$/))) {
$r->print('
'.&mt('Illegal filename.').'
');
return;
}
# Check if quota exceeded
my $filesize = length($env{'form.upfile'});
if (!$filesize) {
$r->print('
'.
&mt('Unable to upload [_1]. (size = [_2] bytes)',
''.$env{'form.upfile.filename'}.'',
$filesize).' '.
&mt('Either the file you attempted to upload was empty, or your web browser was unable to read its contents.').' '.
'
'.
&earlyout($fn,$uname,$udom));
return;
}
$filesize = int($filesize/1000); #expressed in kb
my $output = &Apache::loncommon::excess_filesize_warning($uname,$udom,'author',
$env{'form.upfile.filename'},$filesize,'upload');
if ($output) {
$r->print($output.&earlyout($fn,$uname,$udom));
return;
}
# Split part that I can change from the part that I cannot change
my ($fn1,$fn2)=($fn=~/^(\/priv\/[^\/]+\/[^\/]+\/)(.*)$/);
# Check for pattern: .number.extension which is reserved for LON-CAPA versioning.
# Check for disallowed characters: #?&%:<>`|, and remove
if ($fn2 ne '') {
($fn2,my $warning) = &check_filename($fn2);
if ($warning ne '') {
$r->print($warning);
}
}
# Display additional options for upload
# and upload button
$r->print(
''
);
# Check for bad extension and warn user
if ($fn=~/\.(\w+)$/ &&
(&Apache::loncommon::fileembstyle($1) eq 'hdn')) {
$r->print('
'
.&mt('The extension on this file, [_1], is reserved internally by LON-CAPA.',
''.$1.'')
.' '.&mt('Please change the extension.')
.'
'
.&mt('The extension on this file, [_1], is not recognized by LON-CAPA.',
''.$1.'')
.' '.&mt('Please change the extension.')
.'
');
}
}
sub phasetwo {
my ($r,$fn,$mode)=@_;
my $output;
my $action = '/adm/upload';
my $returnflag = '';
if ($mode eq 'testbank') {
$action = '/adm/testbank';
} elsif ($mode eq 'imsimport') {
$action = '/adm/imsimport';
}
$fn=~s/\/+/\//g;
if ($fn) {
my $target= $r->dir_config('lonDocRoot').'/'.$fn;
&Debug($r, "target -> ".$target);
# target is the full filesystem path of the destination file.
my $base = &File::Basename::basename($fn);
my $path = &File::Basename::dirname($fn);
$base = &HTML::Entities::encode($base,'<>&"');
my $url = $path."/".$base;
&Debug($r, "URL is now ".$url);
my $datatoken;
if ($env{'form.datatoken'} =~ /^$match_username\_$match_domain\_upload_\w*_\d+_\d+$/) {
$datatoken = $env{'form.datatoken'};
}
if (($fn) && ($datatoken)) {
if ($env{'form.cancel'}) {
my $source=$r->dir_config('lonDaemons').'/tmp/'.$datatoken.'.tmp';
my $dirpath=$path.'/';
$dirpath=~s/\/+/\//g;
$output .= '
'.&mt('Or [_1]continue[_2] the testbank import without these files.','','').'
';
}
} else {
$result .= '
'.&mt('Completed upload of the file.').'
'.$embedded;
if ($pathchg) {
if ($mode eq 'testbank') {
$returnflag = 'embedded';
$result .= '
'.&mt('Or [_1]continue[_2] the testbank import without modifying the reference(s).','','').'
';
}
}
}
}
}
}
if (($mode ne 'imsimport') && ($mode ne 'testbank')) {
$result .= ' '.
&mt('View file').'';
}
} else {
$result .= &mt('Failed to copy: [_1].',$!);
}
if ($mode ne 'imsimport' && $mode ne 'testbank') {
$result .= ' '.
&mt('Back to Directory').' ';
}
return ($result,$returnflag);
}
sub check_filename {
my ($fname) = @_;
my $warning;
if ($fname =~/[#\?&%":<>`|]/) {
$fname =~s/[#\?&%":<>`|]//g;
$warning .= '
'
.&mt('Removed one or more disallowed characters from filename')
.'
';
}
if ($fname=~ /\.(\d+)\.(\w+)$/) {
my $num = $1;
$warning .= '
'
.&mt('Bad filename [_1]',''.$fname.'')
.' '
.&mt('[_1](name).(number).(extension)[_2] not allowed.','','')
.' '
.&mt('Replacing the [_1].number.[_2] with [_1]_letter.[_2] in requested filename.','','')
.'
';
if ($num eq '0') {
$fname =~ s/\.(\d+)(\.\w+)$/_A$2/;
} else {
my $letts = '';
my %digletter = reverse &Apache::lonnet::letter_to_digits();
if ($num >= 100) {
$num = substr($num,-2);
}
foreach my $digit (split('',$num)) {
$letts .= $digletter{$digit};
}
$fname =~ s/\.(\d+)(\.\w+)$/_$letts$2/;
}
}
if ($fname =~/___/) {
$fname =~s/_+/_/g;
$warning .= '
'
.&mt('Changed ___ to a single _ in filename')
.'
';
}
return ($fname,$warning);
}
sub phasethree {
my ($r,$fn,$uname,$udom,$mode) = @_;
my $action = '/adm/upload';
if ($mode eq 'testbank') {
$action = '/adm/testbank';
} elsif ($mode eq 'imsimport') {
$action = '/adm/imsimport';
}
my $url_root = "/priv/$udom/$uname";
my $dir_root = $r->dir_config('lonDocRoot').$url_root;
my $path = &File::Basename::dirname($fn);
$path =~ s{^\Q$url_root\E}{};
my $dirpath = $url_root.$path.'/';
$dirpath=~s{/+}{/}g;
my $filename = &HTML::Entities::encode($env{'form.filename'},'<>&"');
my $state = &embedded_form_elems('modify_orightml',$filename,$mode).
'';
my ($result,$returnflag) =
&Apache::loncommon::upload_embedded($mode,$path,$uname,$udom,
$dir_root,$url_root,undef,
undef,undef,$state,$action);
if ($mode ne 'imsimport' && $mode ne 'testbank') {
$result .= '