--- loncom/lonnet/perl/lonnet.pm 2004/04/30 23:10:11 1.493 +++ loncom/lonnet/perl/lonnet.pm 2004/05/19 17:13:39 1.502 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.493 2004/04/30 23:10:11 albertel Exp $ +# $Id: lonnet.pm,v 1.502 2004/05/19 17:13:39 matthew 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. @@ -1309,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++) { @@ -1319,21 +1325,21 @@ 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'; } } @@ -1810,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') { @@ -4456,7 +4462,7 @@ sub numval2 { } sub latest_rnd_algorithm_id { - return '64bit2'; + return '64bit3'; } sub getCODE { @@ -4481,6 +4487,8 @@ sub rndseed { my $which=$ENV{"course.$courseid.rndseed"}; 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 +4548,28 @@ sub rndseed_64bit2 { 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_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");