--- loncom/lonnet/perl/lonnet.pm 2004/02/02 20:21:25 1.470 +++ loncom/lonnet/perl/lonnet.pm 2004/03/16 20:15:08 1.477 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.470 2004/02/02 20:21:25 www Exp $ +# $Id: lonnet.pm,v 1.477 2004/03/16 20:15:08 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'; } @@ -1183,7 +1171,8 @@ sub tokenwrapper { $uri=~s/^\///; $ENV{'user.environment'}=~/\/([^\/]+)\.id/; my $token=$1; - if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { +# if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { + if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/(.+)(\?\.*)*$/) { &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. @@ -1192,7 +1181,61 @@ sub tokenwrapper { return '/adm/notfound.html'; } } - + +# --------------- 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 +# +# Allows directory structure to be used within lonUsers/../userfiles/ for a course. +# +# action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will +# be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in course's home server. +# +# action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will be copied +# from $source (current location) 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. + +sub process_coursefile { + my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_; + my $fetchresult; + if ($action eq 'propagate') { + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file + ,$docuhome); + } elsif ($action eq 'copy') { + my $fetchresult = ''; + my $fpath = ''; + my $fname = $file; + ($fpath,$fname) = ($file =~ m/^(.*)\/([^\/]+)$/); + $fpath=$docudom.'/'.$docuname.'/'.$fpath; + my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; + unless ($fpath eq '') { + my @parts=split(/\//,$fpath); + foreach my $part (@parts) { + $filepath.= '/'.$part; + if ((-e $filepath)!=1) { + mkdir($filepath,0777); + } + } + } + if ($source eq '') { + $fetchresult = 'no source file'; + } else { + my $destination = $filepath.'/'.$fname; + print STDERR "Getting ready to rename $source to $destination\n"; + rename($source,$destination); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $docuhome); + } + } + unless ( ($fetchresult eq 'ok') || ($fetchresult eq 'no source file') ) { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$docuhome.': '.$fetchresult); + } + return $fetchresult; +} + # --------------- Take an uploaded file and put it into the userfiles directory # input: name of form element, coursedoc=1 means this is for the course # output: url of file in userspace @@ -1248,9 +1291,8 @@ sub finishuserfileupload { } # Notify homeserver to grep it # - - my $fetchresult= - &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome); + my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname, + $docuhome); if ($fetchresult eq 'ok') { # # Return the URL to it @@ -3861,7 +3903,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|home/[^/]+/public_html/|) || ($uri =~ m|^uploaded/|)) { return undef; } my $filename=$uri; @@ -4410,49 +4452,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 { @@ -4475,6 +4551,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; }