--- loncom/lonnet/perl/lonnet.pm 2004/04/01 15:24:44 1.484
+++ loncom/lonnet/perl/lonnet.pm 2004/05/10 23:18:27 1.499
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.484 2004/04/01 15:24:44 albertel Exp $
+# $Id: lonnet.pm,v 1.499 2004/05/10 23:18:27 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -32,7 +32,8 @@ package Apache::lonnet;
use strict;
use LWP::UserAgent();
use HTTP::Headers;
-use Date::Parse;
+use HTTP::Date;
+# use Date::Parse;
use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
@@ -616,6 +617,7 @@ sub idput {
my ($udom,%ids)=@_;
my %servers=();
foreach (keys %ids) {
+ &cput('environment',{'id'=>$ids{$_}},$udom,$_);
my $uhom=&homeserver($_,$udom);
if ($uhom ne 'no_host') {
my $id=&escape($ids{$_});
@@ -626,7 +628,6 @@ sub idput {
} else {
$servers{$uhom}=$id.'='.$unam;
}
- &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
}
}
foreach (keys %servers) {
@@ -641,14 +642,18 @@ sub assign_access_key {
# a valid key looks like uname:udom#comments
# comments are being appended
#
- my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;
+ my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
+ $kdom=
+ $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom));
+ $knum=
+ $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum));
$cdom=
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
$udom=$ENV{'user.name'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));
- my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
+ my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {
# assigned to this person
@@ -657,8 +662,8 @@ sub assign_access_key {
# the first time around
# ready to assign
$logentry=$1.'; '.$logentry;
- if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},
- $cdom,$cnum) eq 'ok') {
+ if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
+ $kdom,$knum) eq 'ok') {
# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {
@@ -754,8 +759,8 @@ sub validate_access_key {
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
- $udom=$ENV{'user.name'} unless (defined($udom));
- $uname=$ENV{'user.domain'} unless (defined($uname));
+ $udom=$ENV{'user.domain'} unless (defined($udom));
+ $uname=$ENV{'user.name'} unless (defined($uname));
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
}
@@ -1164,29 +1169,24 @@ sub externalssi {
return $response->content;
}
-# ------- Add a token to a remote URI's query string to vouch for access rights
+# -------------------------------- Allow a /uploaded/ URI to be vouched for
-sub tokenwrapper {
- my $uri=shift;
- $uri=~s/^http\:\/\/([^\/]+)//;
- $uri=~s/^\///;
- $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
- my $token=$1;
-# if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
- if ($uri=~m|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.*)*$|) {
- &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
- return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
- (($uri=~/\?/)?'&':'?').'token='.$token.
- '&tokenissued='.$perlvar{'lonHostID'};
- } else {
- return '/adm/notfound.html';
- }
+sub allowuploaded {
+ my ($srcurl,$url)=@_;
+ $url=&clutter(&declutter($url));
+ my $dir=$url;
+ $dir=~s/\/[^\/]+$//;
+ my %httpref=();
+ my $httpurl=&hreflocation('',$url);
+ $httpref{'httpref.'.$httpurl}=$srcurl;
+ &Apache::lonnet::appenv(%httpref);
}
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
# input: action, courseID, current domain, home server for course, intended
# path to file, source of file.
-# output: ok if successful, diagnostic message otherwise
+# output: url to file (if action was uploaddoc),
+# ok if successful, or diagnostic message otherwise (if action was propagate or copy)
#
# Allows directory structure to be used within lonUsers/../userfiles/ for a
# course.
@@ -1201,8 +1201,9 @@ sub tokenwrapper {
# and will then be copied to
# /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
# course's home server.
+#
# action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
-# will be retrived from $ENV{form.$source} via DOCS interface to
+# will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to
# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
# and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
# in course's home server.
@@ -1255,7 +1256,7 @@ sub process_coursefile {
}
}
}
- unless ( ($fetchresult eq 'ok') || ($fetchresult eq 'no source file') ) {
+ unless ( $fetchresult eq 'ok') {
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
' to host '.$docuhome.': '.$fetchresult);
}
@@ -1267,7 +1268,8 @@ sub process_coursefile {
# output: url of file in userspace
sub userfileupload {
- my ($formname,$coursedoc)=@_;
+ my ($formname,$coursedoc,$subdir)=@_;
+ if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$ENV{'form.'.$formname.'.filename'};
# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;
@@ -1280,34 +1282,39 @@ sub userfileupload {
# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }
chop($ENV{'form.'.$formname});
- my $url = '';
# Create the directory if not present
my $docuname='';
my $docudom='';
my $docuhome='';
+ $fname="$subdir/$fname";
if ($coursedoc) {
$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
$docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
if ($ENV{'form.folder'} =~ m/^default/) {
- $url = &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
+ return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
} else {
$fname=$ENV{'form.folder'}.'/'.$fname;
- $url = &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);
+ return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);
}
} else {
$docuname=$ENV{'user.name'};
$docudom=$ENV{'user.domain'};
$docuhome=$ENV{'user.home'};
+ return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
}
- return
- &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
}
sub finishuserfileupload {
my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
+ my ($fnamepath,$file);
+ $file=$fname;
+ if ($fname=~m|/|) {
+ ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
+ $path.=$fnamepath.'/';
+ }
my @parts=split(/\//,$filepath.'/userfiles/'.$path);
my $count;
for ($count=4;$count<=$#parts;$count++) {
@@ -1318,25 +1325,37 @@ sub finishuserfileupload {
}
# Save the file
{
- open(my $fh,'>'.$filepath.'/'.$fname);
+ &Apache::lonnet::logthis("Saving to $filepath $file");
+ open(my $fh,'>'.$filepath.'/'.$file);
print $fh $ENV{'form.'.$formname};
close($fh);
}
# Notify homeserver to grep it
#
- my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
- $docuhome);
+ my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {
#
# Return the URL to it
- return '/uploaded/'.$path.$fname;
+ return '/uploaded/'.$path.$file;
} else {
- &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.
- ' to host '.$docuhome.': '.$fetchresult);
+ &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
+ ': '.$fetchresult);
return '/adm/notfound.html';
}
}
+sub removeuploadedurl {
+ my ($url)=@_;
+ my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
+ return &Apache::lonnet::removeuserfile($uname,$udom,$fname);
+}
+
+sub removeuserfile {
+ my ($docuname,$docudom,$fname)=@_;
+ my $home=&homeserver($docuname,$docudom);
+ return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
+}
+
# ------------------------------------------------------------------------- Log
sub log {
@@ -1797,7 +1816,7 @@ sub hash2str {
sub hashref2str {
my ($hashref)=@_;
my $result='__HASH_REF__';
- foreach (keys(%$hashref)) {
+ foreach (sort(keys(%$hashref))) {
if (ref($_) eq 'ARRAY') {
$result.=&arrayref2str($_).'=';
} elsif (ref($_) eq 'HASH') {
@@ -2681,10 +2700,15 @@ sub allowed {
# URI is an uploaded document for this course
- if (($priv eq 'bre') &&
- ($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {
- return 'F';
+ if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
+ my $refuri=$ENV{'httpref.'.$orguri};
+ if ($refuri) {
+ if ($refuri =~ m|^/adm/|) {
+ $thisallowed='F';
+ }
+ }
}
+
# Full access at system, domain or course-wide level? Exit.
if ($thisallowed=~/F/) {
@@ -3306,9 +3330,10 @@ sub modify_student_enrollment {
}
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
$first,$middle);
- my $value=&escape($uname.':'.$udom).'='.
- &escape(join(':',$end,$start,$uid,$usec,$fullname,$type));
- my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);
+ my $reply=cput('classlist',
+ {"$uname:$udom" =>
+ join(':',$end,$start,$uid,$usec,$fullname,$type) },
+ $cdom,$cnum);
unless (($reply eq 'ok') || ($reply eq 'delayed')) {
return 'error: '.$reply;
}
@@ -3936,7 +3961,7 @@ sub metadata {
# if it is a non metadata possible uri return quickly
if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
- ($uri =~ m|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) {
+ ($uri =~ m|home/[^/]+/public_html/|)) {
return undef;
}
my $filename=$uri;
@@ -3965,7 +3990,10 @@ sub metadata {
}
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
- my $metastring=&getfile(&filelocation('',&clutter($filename)));
+ my $metastring;
+ if ($uri !~ m|^uploaded/|) {
+ $metastring=&getfile(&filelocation('',&clutter($filename)));
+ }
my $parser=HTML::LCParser->new(\$metastring);
my $token;
undef %metathesekeys;
@@ -4081,14 +4109,14 @@ sub metadata {
#&logthis("extsion1 $extension $key !!");
#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }
- &metadata_create_pacakge_def($uri,$key,'extension_'.$extension,
+ &metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);
}
if (!exists($metacache{$uri}->{':packages'})) {
foreach my $key (sort(keys(%packagetab))) {
#no specific packages well let's get default then
if ($key!~/^default&/) { next; }
- &metadata_create_pacakge_def($uri,$key,'default',
+ &metadata_create_package_def($uri,$key,'default',
\%metathesekeys);
}
}
@@ -4120,7 +4148,7 @@ sub metadata {
return $metacache{$uri}->{':'.$what};
}
-sub metadata_create_pacakge_def {
+sub metadata_create_package_def {
my ($uri,$key,$package,$metathesekeys)=@_;
my ($pack,$name,$subp)=split(/\&/,$key);
if ($subp eq 'default') { next; }
@@ -4437,6 +4465,15 @@ sub latest_rnd_algorithm_id {
return '64bit2';
}
+sub getCODE {
+ if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
+ if (defined($Apache::lonhomework::parsing_a_problem) &&
+ defined($Apache::lonhomework::history{'resource.CODE'})) {
+ return $Apache::lonhomework::history{'resource.CODE'};
+ }
+ return undef;
+}
+
sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;
@@ -4448,8 +4485,7 @@ sub rndseed {
if (!$domain) { $domain=$wdomain; }
if (!$username) { $username=$wusername }
my $which=$ENV{"course.$courseid.rndseed"};
- my $CODE=$ENV{'form.CODE'};
- if (defined($CODE)) {
+ if (defined(&getCODE())) {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit2') {
return &rndseed_64bit2($symb,$courseid,$domain,$username);
@@ -4524,8 +4560,8 @@ sub rndseed_CODE_64bit {
use integer;
my $symbchck=unpack("%32S*",$symb.' ') << 16;
my $symbseed=numval2($symb);
- my $CODEchck=unpack("%32S*",$ENV{'form.CODE'}.' ') << 16;
- my $CODEseed=numval($ENV{'form.CODE'});
+ my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
+ my $CODEseed=numval(&getCODE());
my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEchck;
my $num2=$CODEseed+$courseseed+$symbchck;
@@ -4690,7 +4726,7 @@ sub getuploaded {
return 'failed';
}
if ($reqtype eq 'HEAD') {
- $$info = &Date::Parse::str2time( $response->header('Last-modified') );
+ $$info = &HTTP::Date::str2time( $response->header('Last-modified') );
} elsif ($reqtype eq 'GET') {
$$info = $response->content;
}