--- loncom/lonnet/perl/lonnet.pm 2004/04/29 17:25:11 1.492 +++ loncom/lonnet/perl/lonnet.pm 2004/06/29 04:30:00 1.515 @@ -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.515 2004/06/29 04:30:00 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -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\#/); } @@ -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; @@ -1285,6 +1286,7 @@ sub userfileupload { 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 +1309,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 +1325,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); @@ -1601,21 +1615,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)}=&unescape($value); + } } } - } } return %returnhash; @@ -1624,6 +1639,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 +1839,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') { @@ -3017,6 +3054,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; @@ -3061,6 +3151,54 @@ 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); +} + # ------------------------------------------------------------------ Plain Text sub plaintext { @@ -3251,7 +3389,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 +3404,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 +3455,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; @@ -3442,6 +3579,39 @@ sub revokecustomrole { $deleteflag); } + +# ------------------------------------------------------------ Portfolio Director Lister +sub portfoliolist { +#FIXME us the ls: command instead please +#FIXME uhome should never be an argument to any lonnet functions + # returns listing of contents of user's /userfiles/portfolio/ directory + # + my ($udom,$uname,$uhome); + $uname=$ENV{'user.name'}; + $udom=$ENV{'user.domain'}; + $uhome=$ENV{'user.home'}; + my $listing = &reply('portls:'.$uname.':'.$udom, $uhome); + 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 { @@ -4237,7 +4407,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 +4420,7 @@ sub symbverify { unless ($url eq $thisfn) { return 0; } $symb=&symbclean($symb); + $thisurl=&deversion($thisurl); $thisfn=&deversion($thisfn); my %bighash; @@ -4254,9 +4428,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 +4459,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 +4625,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 +4656,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 +4728,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 +4763,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); @@ -4807,7 +5017,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;