--- loncom/lonnet/perl/lonnet.pm 2004/03/31 19:25:08 1.481 +++ loncom/lonnet/perl/lonnet.pm 2004/07/16 17:56:01 1.522 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.481 2004/03/31 19:25:08 raeburn Exp $ +# $Id: lonnet.pm,v 1.522 2004/07/16 17:56:01 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -32,12 +32,13 @@ 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 %courselogs %accesshash %userrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir); @@ -433,7 +434,7 @@ sub overloaderror { if ($overload>0) { $r->err_headers_out->{'Retry-After'}=$overload; $r->log_error('Overload of '.$overload.' on '.$checkserver); - return 413; + return 409; } return ''; } @@ -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 { @@ -1376,10 +1395,12 @@ sub flushcourselogs { } if ($courseidbuffer{$coursehombuf{$crsid}}) { $courseidbuffer{$coursehombuf{$crsid}}.='&'. - &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). + '='.&escape($courseinstcodebuf{$crsid}); } else { $courseidbuffer{$coursehombuf{$crsid}}= - &escape($crsid).'='.&escape($coursedescrbuf{$crsid}); + &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). + '='.&escape($courseinstcodebuf{$crsid}); } } # @@ -1453,6 +1474,8 @@ sub courselog { $ENV{'course.'.$ENV{'request.course.id'}.'.home'}; $coursedescrbuf{$ENV{'request.course.id'}}= $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; + $courseinstcodebuf{$ENV{'request.course.id'}}= + $ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'}; if (defined $courselogs{$ENV{'request.course.id'}}) { $courselogs{$ENV{'request.course.id'}}.='&'.$what; } else { @@ -1577,7 +1600,7 @@ sub getannounce { if ($announcement=~/\w/) { return ''. - '
'.$announcement.'
'; + ''.$announcement.''; } else { return ''; } @@ -1596,21 +1619,22 @@ sub courseidput { } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter)=@_; + my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } foreach my $tryserver (keys %libserv) { - if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { - foreach ( - split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. + if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { + if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { + foreach ( + split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. $sincefilter.':'.&escape($descfilter), $tryserver))) { - my ($key,$value)=split(/\=/,$_); - if (($key) && ($value)) { - $returnhash{&unescape($key)}=&unescape($value); + my ($key,$value)=split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)}=$value; + } } } - } } return %returnhash; @@ -1619,6 +1643,28 @@ sub courseiddump { # # ----------------------------------------------------------- Check out an item +sub get_first_access { + my ($type,$argsymb)=@_; + my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + if ($argsymb) { $symb=$argsymb; } + my ($map,$id,$res)=&decode_symb($symb); + if ($type eq 'map') { $res=$map; } + my %times=&get('firstaccesstimes',[$res],$udom,$uname); + return $times{$res}; +} + +sub set_first_access { + my ($type)=@_; + my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); + my ($map,$id,$res)=&decode_symb($symb); + if ($type eq 'map') { $res=$map; } + my $firstaccess=&get_first_access($type); + if (!$firstaccess) { + return &put('firstaccesstimes',{$res=>time},$udom,$uname); + } + return 'already_set'; +} + sub checkout { my ($symb,$tuname,$tudom,$tcrsid)=@_; my $now=time; @@ -1797,7 +1843,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 +2727,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/) { @@ -3007,6 +3058,59 @@ sub log_query { return get_query_reply($queryid); } +# ------- Request retrieval of institutional classlists for course(s) + +sub fetch_enrollment_query { + my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; + my $homeserver; + if ($context eq 'automated') { + $homeserver = $perlvar{'lonHostID'}; + } else { + $homeserver = &homeserver($cnum,$dom); + } + my $host=$hostname{$homeserver}; + my $cmd = ''; + foreach (keys %{$affiliatesref}) { + $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; + } + $cmd =~ s/%%$//; + $cmd = &escape($cmd); + my $query = 'fetchenrollment'; + my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); + unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; } + my $reply = &get_query_reply($queryid); + unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + my @responses = split/:/,$reply; + if ($homeserver eq $perlvar{'lonHostID'}) { + foreach (@responses) { + my ($key,$value) = split/=/,$_; + $$replyref{$key} = $value; + } + } else { + my $pathname = $perlvar{'lonDaemons'}.'/tmp'; + foreach (@responses) { + my ($key,$value) = split/=/,$_; + $$replyref{$key} = $value; + if ($value > 0) { + foreach (@{$$affiliatesref{$key}}) { + my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; + my $destname = $pathname.'/'.$filename; + my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); + unless ($xml_classlist =~ /^error/) { + if ( open(FILE,">$destname") ) { + print FILE &unescape($xml_classlist); + close(FILE); + } + } + } + } + } + } + return 'ok'; + } + return 'error'; +} + sub get_query_reply { my $queryid=shift; my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; @@ -3051,6 +3155,80 @@ sub userlog_query { return &log_query($uname,$udom,'userlog',%filters); } +#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course + +sub auto_run { + my ($cnum,$cdom) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response = &reply('autorun:'.$cdom,$homeserver); + return $response; +} + +sub auto_get_sections { + my ($cnum,$cdom,$inst_coursecode) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my @secs = (); + my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); + unless ($response eq 'refused') { + @secs = split/:/,$response; + } + return @secs; +} + +sub auto_new_course { + my ($cnum,$cdom,$inst_course_id,$owner) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); + return $response; +} + +sub auto_validate_courseID { + my ($cnum,$cdom,$inst_course_id) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); + return $response; +} + +sub auto_create_password { + my ($cnum,$cdom,$authparam) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $create_passwd = 0; + my $authchk = ''; + my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); + if ($response eq 'refused') { + $authchk = 'refused'; + } else { + ($authparam,$create_passwd,$authchk) = split/:/,$response; + } + return ($authparam,$create_passwd,$authchk); +} + +sub auto_instcode_format { + my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; + my $courses = ''; + my $homeserver; + if ($caller eq 'global') { + $homeserver = $perlvar{'lonHostID'}; + } else { + $homeserver = &homeserver($caller,$codedom); + } + my $host=$hostname{$homeserver}; + foreach (keys %{$instcodes}) { + $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; + } + chop($courses); + my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); + unless ($response =~ /(con_lost|error|no_such_host|refused)/) { + my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; + %{$codes} = &str2hash($codes_str); + @{$codetitles} = &str2array($codetitles_str); + %{$cat_titles} = &str2hash($cat_titles_str); + %{$cat_order} = &str2hash($cat_order_str); + return 'ok'; + } + return $response; +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -3241,7 +3419,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, - $end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_; + $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_; if (!$cid) { unless ($cid=$ENV{'request.course.id'}) { return 'not_in_class'; @@ -3256,13 +3434,12 @@ sub modifystudent { # students environment $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, - $gene,$usec,$end,$start,$type,$cid); + $gene,$usec,$end,$start,$type,$locktype,$cid); return $reply; } sub modify_student_enrollment { - my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, - $cid) = @_; + my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$ENV{'request.course.id'}) { @@ -3306,9 +3483,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,$locktype) }, + $cdom,$cnum); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; } @@ -3343,7 +3521,7 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url,$course_server,$nonstandard)=@_; + my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_; $url=&declutter($url); my $cid=''; unless (&allowed('ccc',$udom)) { @@ -3376,9 +3554,9 @@ sub createcourse { return 'error: no such course'; } # ----------------------------------------------------------------- Course made -# log existance - &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description), - $uhome); +# log existence + &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). + '='.&escape($inst_code),$uhome); &flushcourselogs(); # set toplevel url my $topurl=$url; @@ -3431,6 +3609,42 @@ sub revokecustomrole { $deleteflag); } + +# ------------------------------------------------------------ Portfolio Director Lister +# returns listing of contents of user's /userfiles/portfolio/ directory +# + +sub portfoliolist { + my ($currentPath, $currentFile) = @_; + my ($udom, $uname, $portfolioRoot); + $uname=$ENV{'user.name'}; + $udom=$ENV{'user.domain'}; + # really should interrogate the system for home directory information, but . . . + $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/'; + $uname =~ /^(.?)(.?)(.?)/; + $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio'; + my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom)); + return $listing; +} + +sub portfoliomanage { + +#FIXME please user the existing remove userfile function instead and +#add a userfilerename functions. +#FIXME uhome should never be an argument to any lonnet functions + + # handles deleting and renaming files in user's userfiles/portfolio/ directory + # + my ($filename, $fileaction, $filenewname) = @_; + my ($udom, $uname, $uhome); + $uname=$ENV{'user.name'}; + $udom=$ENV{'user.domain'}; + $uhome=$ENV{'user.home'}; + my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome); + return $listing; +} + + # ------------------------------------------------------------ Directory lister sub dirlist { @@ -3936,7 +4150,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 +4179,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; @@ -4076,6 +4293,22 @@ sub metadata { # the next is the end of "start tag" } } + my ($extension) = ($uri =~ /\.(\w+)$/); + foreach my $key (sort(keys(%packagetab))) { + #&logthis("extsion1 $extension $key !!"); + #no specific packages #how's our extension + if ($key!~/^extension_\Q$extension\E&/) { next; } + &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_package_def($uri,$key,'default', + \%metathesekeys); + } + } # are there custom rights to evaluate if ($metacache{$uri}->{':copyright'} eq 'custom') { @@ -4104,6 +4337,30 @@ sub metadata { return $metacache{$uri}->{':'.$what}; } +sub metadata_create_package_def { + my ($uri,$key,$package,$metathesekeys)=@_; + my ($pack,$name,$subp)=split(/\&/,$key); + if ($subp eq 'default') { next; } + + if (defined($metacache{$uri}->{':packages'})) { + $metacache{$uri}->{':packages'}.=','.$package; + } else { + $metacache{$uri}->{':packages'}=$package; + } + my $value=$packagetab{$key}; + my $unikey; + $unikey='parameter_0_'.$name; + $metacache{$uri}->{':'.$unikey.'.part'}=0; + $$metathesekeys{$unikey}=1; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; + } + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; + } +} + sub metadata_generate_part0 { my ($metadata,$metacache,$uri) = @_; my %allnames; @@ -4183,7 +4440,10 @@ sub symblist { # --------------------------------------------------------------- Verify a symb sub symbverify { - my ($symb,$thisfn)=@_; + my ($symb,$thisurl)=@_; + my $thisfn=$thisurl; +# wrapper not part of symbs + $thisfn=~s/^\/adm\/wrapper//; $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } @@ -4193,6 +4453,7 @@ sub symbverify { unless ($url eq $thisfn) { return 0; } $symb=&symbclean($symb); + $thisurl=&deversion($thisurl); $thisfn=&deversion($thisfn); my %bighash; @@ -4200,9 +4461,9 @@ sub symbverify { if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { - my $ids=$bighash{'ids_'.&clutter($thisfn)}; + my $ids=$bighash{'ids_'.&clutter($thisurl)}; unless ($ids) { - $ids=$bighash{'ids_/'.$thisfn}; + $ids=$bighash{'ids_/'.$thisurl}; } if ($ids) { # ------------------------------------------------------------------- Has ID(s) @@ -4231,6 +4492,9 @@ sub symbclean { # remove version from URL $symb=~s/\.(\d+)\.(\w+)$/\.$2/; +# remove wrapper + + $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; return $symb; } @@ -4378,8 +4642,41 @@ 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'; + return '64bit3'; +} + +sub get_rand_alg { + my ($courseid)=@_; + if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; } + if ($courseid) { + return $ENV{"course.$courseid.rndseed"}; + } + return &latest_rnd_algorithm_id(); +} + +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 { @@ -4392,10 +4689,11 @@ sub rndseed { if (!$courseid) { $courseid=$wcourseid; } 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); + my $which=&get_rand_alg(); + if (defined(&getCODE())) { + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit3') { + return &rndseed_64bit3($symb,$courseid,$domain,$username); } elsif ($which eq '64bit2') { return &rndseed_64bit2($symb,$courseid,$domain,$username); } elsif ($which eq '64bit') { @@ -4463,26 +4761,49 @@ sub rndseed_64bit2 { } } +sub rndseed_64bit3 { + my ($symb,$courseid,$domain,$username)=@_; + { + use integer; + # strings need to be an even # of cahracters long, it it is odd the + # last characters gets thrown away + my $symbchck=unpack("%32S*",$symb.' ') << 21; + my $symbseed=numval2($symb) << 10; + my $namechck=unpack("%32S*",$username.' '); + + my $nameseed=numval2($username) << 21; + my $domainseed=unpack("%32S*",$domain.' ') << 10; + my $courseseed=unpack("%32S*",$courseid.' '); + + my $num1=$symbchck+$symbseed+$namechck; + my $num2=$nameseed+$domainseed+$courseseed; + #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&Apache::lonxml::debug("rndseed :$num:$symb"); + return "$num1:$num2"; + } +} + sub rndseed_CODE_64bit { my ($symb,$courseid,$domain,$username)=@_; { 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"; + return "$num1:$num2"; } } sub setup_random_from_rndseed { my ($rndseed)=@_; - if ($rndseed =~/,/) { - my ($num1,$num2)=split(/,/,$rndseed); + if ($rndseed =~/([,:])/) { + my ($num1,$num2)=split(/[,:]/,$rndseed); &Math::Random::random_set_seed(abs($num1),abs($num2)); } else { &Math::Random::random_set_seed_from_phrase($rndseed); @@ -4566,71 +4887,91 @@ sub receipt { sub getfile { my ($file,$caller) = @_; - if ($file=~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { # user file - my $info; - my $cdom = $1; - my $cnum = $2; - my $filename = $3; - my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles'; - my ($lwpresp,$rtncode); - my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename; - if (-e "$localfile") { - my @fileinfo = stat($localfile); - $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode); - if ($lwpresp eq 'ok') { - if ($info > $fileinfo[9]) { - $info = ''; - $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); - if ($lwpresp eq 'ok') { - open (FILE,">$localfile"); - print FILE $info; - close(FILE); - if ($caller eq 'uploadrep') { - return 'ok'; - } else { - return $info; - } - } else { - return -1; - } - } else { - return &readfile($localfile); - } - } else { - if ($rtncode eq '404') { - unlink($localfile); - } - return -1; - } - } else { - $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); - if ($lwpresp eq 'ok') { - my @parts = ($cdom,$cnum); - if ($filename =~ m|^(.+)/[^/]+$|) { - push @parts, split(/\//,$1); - } - foreach my $part (@parts) { - $path .= '/'.$part; - if (!-e $path) { - mkdir($path,0770); - } - } - open (FILE,">$localfile"); - print FILE $info; - close(FILE); - if ($caller eq 'uploadrep') { - return 'ok'; - } else { - return $info; - } - } else { - return -1; - } - } - } else { # normal file from res space + + if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { + # normal file from res space &repcopy($file); return &readfile($file); } + + my $info; + my $cdom = $1; + my $cnum = $2; + my $filename = $3; + my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles'; + my ($lwpresp,$rtncode); + my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename; + if (-e "$localfile") { + my @fileinfo = stat($localfile); + $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + if ($rtncode eq '404') { + unlink($localfile); + } + #my $ua=new LWP::UserAgent; + #my $request=new HTTP::Request('GET',&tokenwrapper($file)); + #my $response=$ua->request($request); + #if ($response->is_success()) { + # return $response->content; + # } else { + # return -1; + # } + return -1; + } + if ($info < $fileinfo[9]) { + return &readfile($localfile); + } + $info = ''; + $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + return -1; + } + } else { + $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $response=$ua->request($request); + if ($response->is_success()) { + return $response->content; + } else { + return -1; + } + } + my @parts = ($cdom,$cnum); + if ($filename =~ m|^(.+)/[^/]+$|) { + push @parts, split(/\//,$1); + } + foreach my $part (@parts) { + $path .= '/'.$part; + if (!-e $path) { + mkdir($path,0770); + } + } + } + open (FILE,">$localfile"); + print FILE $info; + close(FILE); + if ($caller eq 'uploadrep') { + return 'ok'; + } + return $info; +} + +sub tokenwrapper { + my $uri=shift; + $uri=~s/^http\:\/\/([^\/]+)//; + $uri=~s/^\///; + $ENV{'user.environment'}=~/\/([^\/]+)\.id/; + my $token=$1; + if ($uri=~/^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 getuploaded { @@ -4641,16 +4982,15 @@ sub getuploaded { my $request=new HTTP::Request($reqtype,$uri); my $response=$ua->request($request); $$rtncode = $response->code; - if ($response->is_success()) { - if ($reqtype eq 'HEAD') { - $$info = &Date::Parse::str2time( $response->header('Last-modified') ); - } elsif ($reqtype eq 'GET') { - $$info = $response->content; - } - return 'ok'; - } else { - return 'failed'; + if (! $response->is_success()) { + return 'failed'; + } + if ($reqtype eq 'HEAD') { + $$info = &HTTP::Date::str2time( $response->header('Last-modified') ); + } elsif ($reqtype eq 'GET') { + $$info = $response->content; } + return 'ok'; } sub readfile { @@ -4741,7 +5081,7 @@ sub declutter { sub clutter { my $thisfn='/'.&declutter(shift); - unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) { + unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { $thisfn='/res'.$thisfn; } return $thisfn; @@ -4803,7 +5143,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; @@ -4921,6 +5261,7 @@ BEGIN { open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { + if ($configline !~ /\S/ || $configline=~/^#/) { next; } chomp($configline); my ($short,$plain)=split(/:/,$configline); my ($pack,$name)=split(/\&/,$short);