--- loncom/lonnet/perl/lonnet.pm 2004/04/01 15:12:26 1.483 +++ loncom/lonnet/perl/lonnet.pm 2004/05/07 17:17:50 1.495 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.483 2004/04/01 15:12:26 albertel Exp $ +# $Id: lonnet.pm,v 1.495 2004/05/07 17:17:50 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) { @@ -1164,29 +1165,28 @@ 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 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); +} 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'; - } + &FIXME_blow_up; } # --------- 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; } @@ -4418,10 +4446,34 @@ sub numval { return int($txt); } +sub numval2 { + my $txt=shift; + $txt=~tr/A-J/0-9/; + $txt=~tr/a-j/0-9/; + $txt=~tr/K-T/0-9/; + $txt=~tr/k-t/0-9/; + $txt=~tr/U-Z/0-5/; + $txt=~tr/u-z/0-5/; + $txt=~s/\D//g; + my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); + my $total; + foreach my $val (@txts) { $total+=$val; } + return int($total); +} + 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)=@_; @@ -4433,9 +4485,8 @@ sub rndseed { if (!$domain) { $domain=$wdomain; } if (!$username) { $username=$wusername } my $which=$ENV{"course.$courseid.rndseed"}; - my $CODE=$ENV{'scantron.CODE'}; - if (defined($CODE)) { - &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + if (defined(&getCODE())) { + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); } elsif ($which eq '64bit2') { return &rndseed_64bit2($symb,$courseid,$domain,$username); } elsif ($which eq '64bit') { @@ -4508,12 +4559,13 @@ sub rndseed_CODE_64bit { { use integer; my $symbchck=unpack("%32S*",$symb.' ') << 16; - my $symbseed=numval($symb); - my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; + my $symbseed=numval2($symb); + my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; + my $CODEseed=numval(&getCODE()); my $courseseed=unpack("%32S*",$courseid.' '); - my $num1=$symbseed+$CODEseed; - my $num2=$courseseed+$symbchck; - #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); + my $num1=$symbseed+$CODEchck; + my $num2=$CODEseed+$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); return "$num1,$num2"; } @@ -4674,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; } @@ -4831,7 +4883,7 @@ BEGIN { open(my $config,") { - if ($configline =~ /^[^\#]*PerlSetVar/) { + if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue;