--- loncom/lonnet/perl/lonnet.pm 2004/01/13 16:29:41 1.461 +++ loncom/lonnet/perl/lonnet.pm 2004/03/09 16:25:19 1.476 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.461 2004/01/13 16:29:41 www Exp $ +# $Id: lonnet.pm,v 1.476 2004/03/09 16:25:19 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -377,7 +377,12 @@ sub delenv { return 'error: '.$!; } foreach (@oldenv) { - unless ($_=~/^$delthis/) { print $fh $_; } + if ($_=~/^$delthis/) { + my ($key,undef) = split('=',$_); + delete($ENV{$key}); + } else { + print $fh $_; + } } close($fh); } @@ -524,38 +529,21 @@ sub authenticate { my ($uname,$upass,$udom)=@_; $upass=escape($upass); $uname=~s/\W//g; - if (($perlvar{'lonRole'} eq 'library') && - ($udom eq $perlvar{'lonDefDomain'})) { - my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); - if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { - &logthis("User $uname at $udom authorized by local server"); - return $perlvar{'lonHostID'}; - } - if ($answer eq 'non_authorized') { - &logthis("User $uname at $udom rejected by local server"); - return 'no_host'; - } - } + my $uhome=&homeserver($uname,$udom); + if (!$uhome) { + &logthis("User $uname at $udom is unknown in authenticate"); + return 'no_host'; } - - my $tryserver; - foreach $tryserver (keys %libserv) { - if ($hostdom{$tryserver} eq $udom) { - my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver); - if ($answer =~ /authorized/) { - if ($answer eq 'authorized') { - &logthis("User $uname at $udom authorized by $tryserver"); - return $tryserver; - } - if ($answer eq 'non_authorized') { - &logthis("User $uname at $udom rejected by $tryserver"); - return 'no_host'; - } - } - } + my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); + if ($answer eq 'authorized') { + &logthis("User $uname at $udom authorized by $uhome"); + return $uhome; + } + if ($answer eq 'non_authorized') { + &logthis("User $uname at $udom rejected by $uhome"); + return 'no_host'; } - &logthis("User $uname at $udom could not be authenticated"); + &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); return 'no_host'; } @@ -1198,8 +1186,13 @@ sub tokenwrapper { # output: url of file in userspace sub userfileupload { - my ($formname,$coursedoc)=@_; - my $fname=$ENV{'form.'.$formname.'.filename'}; + my ($formname,$coursedoc,$filename,$fpath,$source)=@_; + my $fname; + if (defined($filename)) { + $fname = $filename; + } else { + $fname=$ENV{'form.'.$formname.'.filename'}; + } # Replace Windows backslashes by forward slashes $fname=~s/\\/\//g; # Get rid of everything but the actual filename @@ -1210,7 +1203,11 @@ sub userfileupload { $fname=~s/[^\w\.\-]//g; # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } - chop($ENV{'form.'.$formname}); + if ( defined($formname) ) { + if ( defined($ENV{'form.'.$formname}) ) { + chop($ENV{'form.'.$formname}); + } + } # Create the directory if not present my $docuname=''; my $docudom=''; @@ -1225,12 +1222,12 @@ sub userfileupload { $docuhome=$ENV{'user.home'}; } return - &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$fpath,$source); } sub finishuserfileupload { - my ($docuname,$docudom,$docuhome,$formname,$fname)=@_; - my $path=$docudom.'/'.$docuname.'/'; + my ($docuname,$docudom,$docuhome,$formname,$fname,$fpath,$source)=@_; + my $path=$docudom.'/'.$docuname.'/'.$fpath; my $filepath=$perlvar{'lonDocRoot'}; my @parts=split(/\//,$filepath.'/userfiles/'.$path); my $count; @@ -1242,15 +1239,20 @@ sub finishuserfileupload { } # Save the file { - open(my $fh,'>'.$filepath.'/'.$fname); - print $fh $ENV{'form.'.$formname}; - close($fh); + if ($source eq '') { + open(my $fh,'>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$formname}; + close($fh); + } else { + my $destination = $filepath.'/'.$fname; + rename($source,$destination); + } } # Notify homeserver to grep it # - my $fetchresult= - &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome); + my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname. + ':'.$fpath,$docuhome); if ($fetchresult eq 'ok') { # # Return the URL to it @@ -1424,7 +1426,7 @@ sub userrolelog { my ($trole,$username,$domain,$area,$tstart,$tend)=@_; if (($trole=~/^ca/) || ($trole=~/^in/) || ($trole=~/^cc/) || ($trole=~/^ep/) || - ($trole=~/^cr/)) { + ($trole=~/^cr/) || ($trole=~/^ta/)) { my (undef,$rudom,$runame,$rsec)=split(/\//,$area); $userrolehash {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} @@ -1436,6 +1438,10 @@ sub get_course_adv_roles { my $cid=shift; $cid=$ENV{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); + my %nothide=(); + foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { + $nothide{join(':',split(/[\@\:]/,$_))}=1; + } my %returnhash=(); my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); @@ -1446,6 +1452,8 @@ sub get_course_adv_roles { if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$_); + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { next; } my $key=&plaintext($role); if ($section) { $key.=' (Sec/Grp '.$section.')'; } if ($returnhash{$key}) { @@ -3821,9 +3829,12 @@ sub packages_tab_default { my $packages=&metadata($uri,'packages'); foreach my $package (split(/,/,$packages)) { my ($pack_type,$pack_part)=split(/_/,$package,2); - if ($pack_part eq $part) { + if (defined($packagetab{"$pack_type&$name&default"})) { return $packagetab{"$pack_type&$name&default"}; } + if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { + return $packagetab{$pack_type."_".$pack_part."&$name&default"}; + } } return undef; } @@ -3852,8 +3863,8 @@ 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/|)) { - return ''; + ($uri =~ m|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) { + return undef; } my $filename=$uri; $uri=~s/\.meta$//; @@ -4401,49 +4412,83 @@ sub setup_random_from_rndseed { } } +sub latest_receipt_algorithm_id { + return 'receipt2'; +} + sub ireceipt { - my ($funame,$fudom,$fucourseid,$fusymb)=@_; + my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; my $cuname=unpack("%32C*",$funame); my $cudom=unpack("%32C*",$fudom); my $cucourseid=unpack("%32C*",$fucourseid); my $cusymb=unpack("%32C*",$fusymb); my $cunique=unpack("%32C*",$perlvar{'lonReceipt'}); - return unpack("%32C*",$perlvar{'lonHostID'}).'-'. - ($cunique%$cuname+ - $cunique%$cudom+ - $cusymb%$cuname+ - $cusymb%$cudom+ - $cucourseid%$cuname+ - $cucourseid%$cudom); + my $cpart=unpack("%32S*",$part); + my $return =unpack("%32C*",$perlvar{'lonHostID'}).'-'; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' || + $ENV{'request.state'} eq 'construct') { + &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname). + " and ".($cpart%$cudom)); + + $return.= ($cunique%$cuname+ + $cunique%$cudom+ + $cusymb%$cuname+ + $cusymb%$cudom+ + $cucourseid%$cuname+ + $cucourseid%$cudom+ + $cpart%$cuname+ + $cpart%$cudom); + } else { + $return.= ($cunique%$cuname+ + $cunique%$cudom+ + $cusymb%$cuname+ + $cusymb%$cudom+ + $cucourseid%$cuname+ + $cucourseid%$cudom); + } + return $return; } sub receipt { - my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); - return &ireceipt($name,$domain,$courseid,$symb); + my ($part)=@_; + my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser(); + return &ireceipt($name,$domain,$courseid,$symb,$part); } # ------------------------------------------------------------ Serves up a file -# returns either the contents of the file or a -1 +# returns either the contents of the file or +# -1 if the file doesn't exist +# -2 if an error occured when trying to aqcuire the file + sub getfile { - my $file=shift; - if ($file=~/^\/*uploaded\//) { # user file - 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; - } - } else { # normal file from res space - &repcopy($file); - if (! -e $file ) { return -1; }; - my $fh; - open($fh,"<$file"); - my $a=''; - while (<$fh>) { $a .=$_; } - return $a; - } + my $file=shift; + if ($file=~/^\/*uploaded\//) { # user file + 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 { + #&logthis("Return Code is ".$response->code." for $file ". + # &tokenwrapper($file)); + # 500 for ISE when tokenwrapper can't figure out what server to + # contact + # 503 when lonuploadacc can't contact the requested server + if ($response->code eq 503 || $response->code eq 500) { + return -2; + } else { + return -1; + } + } + } else { # normal file from res space + &repcopy($file); + if (! -e $file ) { return -1; }; + my $fh; + open($fh,"<$file"); + my $a=''; + while (<$fh>) { $a .=$_; } + return $a; + } } sub filelocation { @@ -4457,7 +4502,7 @@ sub filelocation { $location=$file; } else { $file=~s/^$perlvar{'lonDocRoot'}//; - $file=~s:^/*res::; + $file=~s:^/res/:/:; if ( !( $file =~ m:^/:) ) { $location = $dir. '/'.$file; } else { @@ -4466,6 +4511,7 @@ sub filelocation { } $location=~s://+:/:g; # remove duplicate / while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ return $location; } @@ -4474,13 +4520,38 @@ sub hreflocation { unless (($file=~m-^http://-i) || ($file=~m-^/-)) { my $finalpath=filelocation($dir,$file); $finalpath=~s-^/home/httpd/html--; - $finalpath=~s-/home/(\w+)/public_html/-/~$1/-; + $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-; return $finalpath; } elsif ($file=~m-^/home-) { $file=~s-^/home/httpd/html--; - $file=~s-/home/(\w+)/public_html/-/~$1/-; + $file=~s-^/home/(\w+)/public_html/-/~$1/-; return $file; } + return $file; +} + +sub current_machine_domains { + my $hostname=$hostname{$perlvar{'lonHostID'}}; + my @domains; + while( my($id, $name) = each(%hostname)) { +# &logthis("-$id-$name-$hostname-"); + if ($hostname eq $name) { + push(@domains,$hostdom{$id}); + } + } + return @domains; +} + +sub current_machine_ids { + my $hostname=$hostname{$perlvar{'lonHostID'}}; + my @ids; + while( my($id, $name) = each(%hostname)) { +# &logthis("-$id-$name-$hostname-"); + if ($hostname eq $name) { + push(@ids,$id); + } + } + return @ids; } # ------------------------------------------------------------- Declutters URLs