--- loncom/lonnet/perl/lonnet.pm 2004/04/29 17:25:11 1.492 +++ loncom/lonnet/perl/lonnet.pm 2004/08/23 19:34:01 1.529 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.492 2004/04/29 17:25:11 albertel Exp $ +# $Id: lonnet.pm,v 1.529 2004/08/23 19:34:01 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -38,7 +38,7 @@ 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); @@ -434,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 ''; } @@ -642,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 @@ -658,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') { @@ -755,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\#/); } @@ -1127,10 +1131,10 @@ sub ssi_body { my ($filelink,%form)=@_; my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); - $output=~s/^.*?\]*\>//si; - $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; $output=~ s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; + $output=~s/^.*?\]*\>//si; + $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; return $output; } @@ -1178,10 +1182,6 @@ sub allowuploaded { &Apache::lonnet::appenv(%httpref); } -sub tokenwrapper { - &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. @@ -1268,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; @@ -1281,10 +1282,27 @@ sub userfileupload { # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } chop($ENV{'form.'.$formname}); + if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently + my $now = time; + my $filepath = 'tmp/helprequests/'.$now; + my @parts=split(/\//,$filepath); + my $fullpath = $perlvar{'lonDaemons'}; + for (my $i=0;$i<@parts;$i++) { + $fullpath .= '/'.$parts[$i]; + if ((-e $fullpath)!=1) { + mkdir($fullpath,0777); + } + } + open(my $fh,'>'.$fullpath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + close($fh); + return $fullpath.'/'.$fname; + } # 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'}; @@ -1307,6 +1325,12 @@ 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++) { @@ -1317,25 +1341,31 @@ 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); @@ -1381,10 +1411,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}); } } # @@ -1458,6 +1490,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 { @@ -1582,7 +1616,7 @@ sub getannounce { if ($announcement=~/\w/) { return ''. - '
'.$announcement.'
'; + ''.$announcement.''; } else { return ''; } @@ -1601,21 +1635,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; @@ -1624,6 +1659,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; @@ -1802,7 +1859,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') { @@ -2534,6 +2591,30 @@ sub put { return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } +# ---------------------------------------------------------- putstore interface + +sub putstore { + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + my %allitems = (); + foreach (keys %$storehash) { + if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { + my $key = $1.':keys:'.$2; + $allitems{$key} .= $3.':'; + } + $items.=$_.'='.&escape($$storehash{$_}).'&'; + } + foreach (keys %allitems) { + $allitems{$_} =~ s/\:$//; + $items.= $_.'='.$allitems{$_}.'&'; + } + $items=~s/\&$//; + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); +} + # ------------------------------------------------------ critical put interface sub cput { @@ -2616,8 +2697,8 @@ sub allowed { if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } # Free bre access to adm and meta resources - - if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { + if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) + || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { return 'F'; } @@ -3017,6 +3098,68 @@ 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\_/) { + &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); + return 'error: '.$queryid; + } + my $reply = &get_query_reply($queryid); + if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { + &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum); + } else { + 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); + if ($xml_classlist =~ /^error/) { + &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); + } else { + if ( open(FILE,">$destname") ) { + print FILE &unescape($xml_classlist); + close(FILE); + } else { + &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); + } + } + } + } + } + } + return 'ok'; + } + return 'error'; +} + sub get_query_reply { my $queryid=shift; my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; @@ -3061,6 +3204,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 { @@ -3251,7 +3468,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'; @@ -3266,13 +3483,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'}) { @@ -3318,7 +3534,7 @@ sub modify_student_enrollment { $first,$middle); my $reply=cput('classlist', {"$uname:$udom" => - join(':',$end,$start,$uid,$usec,$fullname,$type) }, + join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, $cdom,$cnum); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; @@ -3354,7 +3570,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)) { @@ -3387,9 +3603,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; @@ -3442,6 +3658,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 { @@ -3945,7 +4197,9 @@ sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); # if it is a non metadata possible uri return quickly - if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || + if (($uri eq '') || + (($uri =~ m|^/*adm/|) && + ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || ($uri =~ m|home/[^/]+/public_html/|)) { return undef; @@ -4237,7 +4491,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; } @@ -4247,6 +4504,7 @@ sub symbverify { unless ($url eq $thisfn) { return 0; } $symb=&symbclean($symb); + $thisurl=&deversion($thisurl); $thisfn=&deversion($thisfn); my %bighash; @@ -4254,9 +4512,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) @@ -4285,6 +4543,9 @@ sub symbclean { # remove version from URL $symb=~s/\.(\d+)\.(\w+)$/\.$2/; +# remove wrapper + + $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; return $symb; } @@ -4448,7 +4709,16 @@ sub numval2 { } 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 { @@ -4470,9 +4740,11 @@ sub rndseed { if (!$courseid) { $courseid=$wcourseid; } if (!$domain) { $domain=$wdomain; } if (!$username) { $username=$wusername } - my $which=$ENV{"course.$courseid.rndseed"}; + 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') { @@ -4540,6 +4812,28 @@ 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)=@_; { @@ -4553,14 +4847,14 @@ sub rndseed_CODE_64bit { 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); @@ -4665,6 +4959,14 @@ sub getfile { 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]) { @@ -4678,12 +4980,19 @@ sub getfile { } else { $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { - return -1; + 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) { @@ -4700,6 +5009,22 @@ sub getfile { 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 { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; @@ -4737,7 +5062,21 @@ sub filelocation { $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; } elsif ($file=~/^\/*uploaded/) { # is an uploaded file - $location=$file; + if ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/(\/)?simplepage\/([^\/]+)$/) { + $location=&Apache::loncommon::propath($1,$2).'/userfiles/simplepage/'.$4; + if (not -e $location) { + $file=~/^\/uploaded\/(.*)$/; + $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1; + } + } elsif ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/aboutme\/([^\/]+)$/) { + $location=&Apache::loncommon::propath($1,$2).'/userfiles/aboutme/'.$3; + if (not -e $location) { + $file=~/^\/uploaded\/(.*)$/; + $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1; + } + } else { + $location=$file; + } } else { $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; $file=~s:^/res/:/:; @@ -4807,7 +5146,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; @@ -5628,6 +5967,17 @@ put($namespace,$storehash,$udom,$uname) =item * +putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp +keys used in storehash include version information (e.g., 1:$symb:message etc.) as +used in records written by &store and retrieved by &restore. This function +was created for use in editing discussion posts, without incrementing the +version number included in the key for a particular post. The colon +separated list of attribute names (e.g., the value associated with the key +1:keys:$symb) is also generated and passed in the ampersand separated +items sent to lonnet::reply(). + +=item * + cput($namespace,$storehash,$udom,$uname) : critical put ($udom and $uname are optional)