--- loncom/lonnet/perl/lonnet.pm 2004/01/30 14:42:00 1.467 +++ loncom/lonnet/perl/lonnet.pm 2004/04/23 19:36:46 1.488 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.467 2004/01/30 14:42:00 matthew Exp $ +# $Id: lonnet.pm,v 1.488 2004/04/23 19:36:46 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -32,6 +32,8 @@ package Apache::lonnet; use strict; use LWP::UserAgent(); use HTTP::Headers; +use HTTP::Date; +# use Date::Parse; use vars qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache @@ -377,7 +379,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 +531,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'; } @@ -627,6 +617,7 @@ sub idput { my ($udom,%ids)=@_; my %servers=(); foreach (keys %ids) { + &cput('environment',{'id'=>$ids{$_}},$udom,$_); my $uhom=&homeserver($_,$udom); if ($uhom ne 'no_host') { my $id=&escape($ids{$_}); @@ -637,7 +628,6 @@ sub idput { } else { $servers{$uhom}=$id.'='.$unam; } - &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom); } } foreach (keys %servers) { @@ -661,7 +651,7 @@ sub assign_access_key { $uname=$ENV{'user.domain'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); if (($existing{$ckey}=~/^\#(.*)$/) || # - new key - ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { + ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { # assigned to this person # - this should not happen, # unless something went wrong @@ -768,7 +758,7 @@ sub validate_access_key { $udom=$ENV{'user.name'} unless (defined($udom)); $uname=$ENV{'user.domain'} unless (defined($uname)); my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); - return ($existing{$ckey}=~/^$uname\:$udom\#/); + return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/); } # ------------------------------------- Find the section of student in a course @@ -796,7 +786,7 @@ sub getsection { &homeserver($unam,$udom)))) { my ($key,$value)=split(/\=/,$_); $key=&unescape($key); - next if ($key !~/^$courseid(?:\/)*(\w+)*\_st$/); + next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); @@ -975,7 +965,7 @@ sub usection { &homeserver($unam,$udom)))) { my ($key,$value)=split(/\=/,$_); $key=&unescape($key); - if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) { + if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) { my $section=$1; if ($key eq $courseid.'_st') { $section=''; } my ($dummy,$end,$start)=split(/\_/,&unescape($value)); @@ -1183,7 +1173,8 @@ sub tokenwrapper { $uri=~s/^\///; $ENV{'user.environment'}=~/\/([^\/]+)\.id/; my $token=$1; - if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { +# if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) { + if ($uri=~m|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.*)*$|) { &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'}); return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. @@ -1192,7 +1183,88 @@ 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: url to file (if action was uploaddoc), +# ok if successful, or diagnostic message otherwise (if action was propagate or copy) +# +# 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/$domain/1/2/3/$course/userfiles/$file in +# course's home server. +# +# action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file +# will be retrived from $ENV{form.uploaddoc} (from DOCS interface) 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); + } else { + 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 ($action eq 'copy') { + if ($source eq '') { + $fetchresult = 'no source file'; + return $fetchresult; + } else { + my $destination = $filepath.'/'.$fname; + rename($source,$destination); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $docuhome); + } + } elsif ($action eq 'uploaddoc') { + open(my $fh,'>'.$filepath.'/'.$fname); + print $fh $ENV{'form.'.$source}; + close($fh); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $docuhome); + if ($fetchresult eq 'ok') { + return '/uploaded/'.$fpath.'/'.$fname; + } else { + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$docuhome.': '.$fetchresult); + return '/adm/notfound.html'; + } + } + } + unless ( $fetchresult eq 'ok') { + &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 @@ -1219,13 +1291,18 @@ sub userfileupload { $docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'}; $docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}; $docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'}; + if ($ENV{'form.folder'} =~ m/^default/) { + return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); + } else { + $fname=$ENV{'form.folder'}.'/'.$fname; + return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname); + } } else { $docuname=$ENV{'user.name'}; $docudom=$ENV{'user.domain'}; $docuhome=$ENV{'user.home'}; + return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); } - return - &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname); } sub finishuserfileupload { @@ -1248,9 +1325,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 @@ -1424,7 +1500,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 +1512,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,7 +1526,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)) { next; } + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { next; } my $key=&plaintext($role); if ($section) { $key.=' (Sec/Grp '.$section.')'; } if ($returnhash{$key}) { @@ -2578,14 +2659,14 @@ sub allowed { # Course - if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) { + if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } # Domain if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } @@ -2595,7 +2676,7 @@ sub allowed { $courseuri=~s/^([^\/])/\/$1/; if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; } @@ -2613,7 +2694,7 @@ sub allowed { # If this is generating or modifying users, exit with special codes - if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) { + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) { return $thisallowed; } # @@ -2634,7 +2715,7 @@ sub allowed { if ($match) { $statecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $checkreferer=0; } @@ -2662,7 +2743,7 @@ sub allowed { if ($match) { my $refstatecond=$cond; if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} - =~/$priv\&([^\:]*)/) { + =~/\Q$priv\E\&([^\:]*)/) { $thisallowed.=$1; $uri=$refuri; $statecond=$refstatecond; @@ -2715,7 +2796,7 @@ sub allowed { if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { &coursedescription($courseid); } - if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) + if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, @@ -2726,7 +2807,7 @@ sub allowed { return ''; } } - if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) + if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { &log($ENV{'user.domain'},$ENV{'user.name'}, @@ -2760,7 +2841,7 @@ sub allowed { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'}; if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} - =~/$rolecode/) { + =~/\Q$rolecode\E/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $ENV{'request.course.id'}); @@ -2768,7 +2849,7 @@ sub allowed { } if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'} - =~/$unamedom/) { + =~/\Q$unamedom\E/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. $ENV{'request.course.id'}); @@ -2780,7 +2861,7 @@ sub allowed { if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; - if (&metadata($uri,'roledeny')=~/$rolecode/) { + if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); return ''; @@ -2792,7 +2873,7 @@ sub allowed { if ($thisallowed=~/X/) { if ($ENV{'acc.randomout'}) { my $symb=&symbread($uri,1); - if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) { + if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) { return ''; } } @@ -2856,27 +2937,27 @@ sub definerole { my ($rolename,$sysrole,$domrole,$courole)=@_; foreach (split(':',$sysrole)) { my ($crole,$cqual)=split(/\&/,$_); - if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; } - if ($pr{'cr:s'}=~/$crole\&/) { - if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) { + if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } + if ($pr{'cr:s'}=~/\Q$crole\E\&/) { + if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { return "refused:s:$crole&$cqual"; } } } foreach (split(':',$domrole)) { my ($crole,$cqual)=split(/\&/,$_); - if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; } - if ($pr{'cr:d'}=~/$crole\&/) { - if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) { + if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } + if ($pr{'cr:d'}=~/\Q$crole\E\&/) { + if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { return "refused:d:$crole&$cqual"; } } } foreach (split(':',$courole)) { my ($crole,$cqual)=split(/\&/,$_); - if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; } - if ($pr{'cr:c'}=~/$crole\&/) { - if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) { + if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } + if ($pr{'cr:c'}=~/\Q$crole\E\&/) { + if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { return "refused:c:$crole&$cqual"; } } @@ -2923,7 +3004,7 @@ sub log_query { my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, $uhome); - unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; } + unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } return get_query_reply($queryid); } @@ -3226,9 +3307,10 @@ sub modify_student_enrollment { } my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene, $first,$middle); - my $value=&escape($uname.':'.$udom).'='. - &escape(join(':',$end,$start,$uid,$usec,$fullname,$type)); - my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome); + my $reply=cput('classlist', + {"$uname:$udom" => + join(':',$end,$start,$uid,$usec,$fullname,$type) }, + $cdom,$cnum); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; } @@ -3822,10 +3904,11 @@ 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&$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; @@ -3855,8 +3938,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$//; @@ -3995,6 +4078,22 @@ sub metadata { # the next is the end of "start tag" } } + my ($extension) = ($uri =~ /\.(\w+)$/); + foreach my $key (sort(keys(%packagetab))) { + #&logthis("extsion1 $extension $key !!"); + #no specific packages #how's our extension + if ($key!~/^extension_\Q$extension\E&/) { next; } + &metadata_create_package_def($uri,$key,'extension_'.$extension, + \%metathesekeys); + } + if (!exists($metacache{$uri}->{':packages'})) { + foreach my $key (sort(keys(%packagetab))) { + #no specific packages well let's get default then + if ($key!~/^default&/) { next; } + &metadata_create_package_def($uri,$key,'default', + \%metathesekeys); + } + } # are there custom rights to evaluate if ($metacache{$uri}->{':copyright'} eq 'custom') { @@ -4023,6 +4122,30 @@ sub metadata { return $metacache{$uri}->{':'.$what}; } +sub metadata_create_package_def { + my ($uri,$key,$package,$metathesekeys)=@_; + my ($pack,$name,$subp)=split(/\&/,$key); + if ($subp eq 'default') { next; } + + if (defined($metacache{$uri}->{':packages'})) { + $metacache{$uri}->{':packages'}.=','.$package; + } else { + $metacache{$uri}->{':packages'}=$package; + } + my $value=$packagetab{$key}; + my $unikey; + $unikey='parameter_0_'.$name; + $metacache{$uri}->{':'.$unikey.'.part'}=0; + $$metathesekeys{$unikey}=1; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; + } + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; + } +} + sub metadata_generate_part0 { my ($metadata,$metacache,$uri) = @_; my %allnames; @@ -4046,7 +4169,7 @@ sub metadata_generate_part0 { my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. '.display'}; my $expr='\\[Part: '.$allnames{$name}.'\\]'; - $olddis=~s/$expr/\[Part: 0\]/; + $olddis=~s/\Q$expr\E/\[Part: 0\]/; $$metacache{"$key.display"}=$olddis; } } @@ -4215,9 +4338,13 @@ sub symbread { my %bighash; my $syval=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { + my $targetfn = $thisfn; + if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { + $targetfn = 'adm/wrapper/'.$thisfn; + } if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', &GDBM_READER(),0640)) { - $syval=$hash{$thisfn}; + $syval=$hash{$targetfn}; untie(%hash); } # ---------------------------------------------------------- There was an entry @@ -4269,7 +4396,7 @@ sub symbread { } } untie(%bighash) - } + } } if ($syval) { return &symbclean($syval.'___'.$thisfn); @@ -4293,6 +4420,21 @@ sub numval { return int($txt); } +sub numval2 { + my $txt=shift; + $txt=~tr/A-J/0-9/; + $txt=~tr/a-j/0-9/; + $txt=~tr/K-T/0-9/; + $txt=~tr/k-t/0-9/; + $txt=~tr/U-Z/0-5/; + $txt=~tr/u-z/0-5/; + $txt=~s/\D//g; + my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); + my $total; + foreach my $val (@txts) { $total+=$val; } + return int($total); +} + sub latest_rnd_algorithm_id { return '64bit2'; } @@ -4308,9 +4450,9 @@ sub rndseed { if (!$domain) { $domain=$wdomain; } if (!$username) { $username=$wusername } my $which=$ENV{"course.$courseid.rndseed"}; - my $CODE=$ENV{'scantron.CODE'}; + my $CODE=$ENV{'form.CODE'}; if (defined($CODE)) { - &rndseed_CODE_64bit($symb,$courseid,$domain,$username); + return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); } elsif ($which eq '64bit2') { return &rndseed_64bit2($symb,$courseid,$domain,$username); } elsif ($which eq '64bit') { @@ -4383,12 +4525,13 @@ sub rndseed_CODE_64bit { { use integer; my $symbchck=unpack("%32S*",$symb.' ') << 16; - my $symbseed=numval($symb); - my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; + my $symbseed=numval2($symb); + my $CODEchck=unpack("%32S*",$ENV{'form.CODE'}.' ') << 16; + my $CODEseed=numval($ENV{'form.CODE'}); my $courseseed=unpack("%32S*",$courseid.' '); - my $num1=$symbseed+$CODEseed; - my $num2=$courseseed+$symbchck; - #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); + my $num1=$symbseed+$CODEchck; + my $num2=$CODEseed+$courseseed+$symbchck; + #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); return "$num1,$num2"; } @@ -4404,49 +4547,166 @@ sub setup_random_from_rndseed { } } +sub latest_receipt_algorithm_id { + return 'receipt2'; +} + +sub recunique { + my $fucourseid=shift; + my $unique; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $unique=$ENV{"course.$fucourseid.internal.encseed"}; + } else { + $unique=$perlvar{'lonReceipt'}; + } + return unpack("%32C*",$unique); +} + +sub recprefix { + my $fucourseid=shift; + my $prefix; + if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') { + $prefix=$ENV{"course.$fucourseid.internal.encpref"}; + } else { + $prefix=$perlvar{'lonHostID'}; + } + return unpack("%32C*",$prefix); +} + 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 $cunique=&recunique($fucourseid); + my $cpart=unpack("%32S*",$part); + my $return =&recprefix($fucourseid).'-'; + 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 +# +# if the target is a file that was uploaded via DOCS, +# a check will be made to see if a current copy exists on the local server, +# if it does this will be served, otherwise a copy will be retrieved from +# the home server for the course and stored in /home/httpd/html/userfiles on +# the local server. + sub getfile { - my $file=shift; - if ($file=~/^\/*uploaded\//) { # user file + my ($file,$caller) = @_; + + if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { + # normal file from res space + &repcopy($file); + return &readfile($file); + } + + my $info; + my $cdom = $1; + my $cnum = $2; + my $filename = $3; + my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles'; + my ($lwpresp,$rtncode); + my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename; + if (-e "$localfile") { + my @fileinfo = stat($localfile); + $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + if ($rtncode eq '404') { + unlink($localfile); + } + return -1; + } + if ($info < $fileinfo[9]) { + return &readfile($localfile); + } + $info = ''; + $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + return -1; + } + } else { + $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); + if ($lwpresp ne 'ok') { + return -1; + } + my @parts = ($cdom,$cnum); + if ($filename =~ m|^(.+)/[^/]+$|) { + push @parts, split(/\//,$1); + } + foreach my $part (@parts) { + $path .= '/'.$part; + if (!-e $path) { + mkdir($path,0770); + } + } + } + open (FILE,">$localfile"); + print FILE $info; + close(FILE); + if ($caller eq 'uploadrep') { + return 'ok'; + } + return $info; +} + +sub getuploaded { + my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; + $uri=~s/^\///; + $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri; my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',&tokenwrapper($file)); + my $request=new HTTP::Request($reqtype,$uri); 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; - } + $$rtncode = $response->code; + if (! $response->is_success()) { + return 'failed'; + } + if ($reqtype eq 'HEAD') { + $$info = &HTTP::Date::str2time( $response->header('Last-modified') ); + } elsif ($reqtype eq 'GET') { + $$info = $response->content; + } + return 'ok'; +} + +sub readfile { + my $file = shift; + if ( (! -e $file ) || ($file eq '') ) { return -1; }; + my $fh; + open($fh,"<$file"); + my $a=''; + while (<$fh>) { $a .=$_; } + return $a; } sub filelocation { @@ -4459,7 +4719,7 @@ sub filelocation { } elsif ($file=~/^\/*uploaded/) { # is an uploaded file $location=$file; } else { - $file=~s/^$perlvar{'lonDocRoot'}//; + $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; $file=~s:^/res/:/:; if ( !( $file =~ m:^/:) ) { $location = $dir. '/'.$file; @@ -4469,6 +4729,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; } @@ -4515,7 +4776,7 @@ sub current_machine_ids { sub declutter { my $thisfn=shift; - $thisfn=~s/^$perlvar{'lonDocRoot'}//; + $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; $thisfn=~s/^\///; $thisfn=~s/^res\///; $thisfn=~s/\?.+$//; @@ -4588,7 +4849,7 @@ BEGIN { open(my $config,") { - if ($configline =~ /^[^\#]*PerlSetVar/) { + if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; @@ -4706,6 +4967,7 @@ BEGIN { open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { + if ($configline !~ /\S/ || $configline=~/^#/) { next; } chomp($configline); my ($short,$plain)=split(/:/,$configline); my ($pack,$name)=split(/\&/,$short); @@ -5451,8 +5713,29 @@ messages of critical importance should g =item * -getfile($file) : returns the entire contents of a file or -1; it -properly subscribes to and replicates the file if neccessary. +getfile($file,$caller) : two cases - requests for files in /res or in /uploaded. +(a) files in /uploaded + (i) If a local copy of the file exists - + compares modification date of local copy with last-modified date for + definitive version stored on home server for course. If local copy is + stale, requests a new version from the home server and stores it. + If the original has been removed from the home server, then local copy + is unlinked. + (ii) If local copy does not exist - + requests the file from the home server and stores it. + + If $caller is 'uploadrep': + This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase) + for request for files originally uploaded via DOCS. + - returns 'ok' if fresh local copy now available, -1 otherwise. + + Otherwise: + This indicates a call from the content generation phase of the request. + - returns the entire contents of the file or -1. + +(b) files in /res + - returns the entire contents of a file or -1; + it properly subscribes to and replicates the file if neccessary. =item *