--- loncom/lonnet/perl/lonnet.pm 2005/06/11 13:38:47 1.637 +++ loncom/lonnet/perl/lonnet.pm 2005/11/15 18:30:41 1.676 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.637 2005/06/11 13:38:47 raeburn Exp $ +# $Id: lonnet.pm,v 1.676 2005/11/15 18:30:41 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -37,7 +37,7 @@ use HTTP::Date; use vars qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom %libserv %pr %prp $memcache %packagetab - %courselogs %accesshash %userrolehash $processmarker $dumpcount + %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit @@ -49,10 +49,11 @@ use Apache::Constants qw(:common :http); use HTML::LCParser; use HTML::Parser; use Fcntl qw(:flock); -use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; +use Digest::MD5; + my $readit; my $max_connection_retries = 10; # Or some such value. @@ -166,7 +167,7 @@ sub reply { unless (defined($hostname{$server})) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { - &logthis("WARNING:". + &logthis("WARNING:". " $cmd to $server returned $answer"); } return $answer; @@ -190,14 +191,14 @@ sub reconlonc { sleep 5; if (-e "$peerfile") { return; } &logthis( - "WARNING: $peerfile still not there, giving up"); + "WARNING: $peerfile still not there, giving up"); } else { &logthis( - "WARNING:". + "WARNING:". " lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('WARNING: lonc not running, giving up'); + &logthis('WARNING: lonc not running, giving up'); } } @@ -206,7 +207,7 @@ sub reconlonc { sub critical { my ($cmd,$server)=@_; unless ($hostname{$server}) { - &logthis("WARNING:". + &logthis("WARNING:". " Critical message to unknown server ($server)"); return 'no_such_host'; } @@ -240,12 +241,12 @@ sub critical { } chomp($wcmd); if ($wcmd eq $cmd) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Connection buffer $dfilename: $cmd"); &logperm("D:$server:$cmd"); return 'con_delayed'; } else { - &logthis("CRITICAL:" + &logthis("CRITICAL:" ." Critical connection failed: $server $cmd"); &logperm("F:$server:$cmd"); return 'con_failed'; @@ -290,7 +291,7 @@ sub appenv { my %newenv=@_; foreach (keys %newenv) { if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Attempt to modify environment ".$_." to ".$newenv{$_} .''); delete($newenv{$_}); @@ -304,7 +305,7 @@ sub appenv { return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain exclusive lock in appenv: '.$!); close($lockfh); return 'error: '.$!; @@ -349,7 +350,7 @@ sub delenv { my $delthis=shift; my %newenv=(); if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); return 'error'; } @@ -360,7 +361,7 @@ sub delenv { return 'error'; } unless (flock($fh,LOCK_SH)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain shared lock in delenv: '.$!); close($fh); return 'error: '.$!; @@ -374,7 +375,7 @@ sub delenv { return 'error'; } unless (flock($fh,LOCK_EX)) { - &logthis("WARNING: ". + &logthis("WARNING: ". 'Could not obtain exclusive lock in delenv: '.$!); close($fh); return 'error: '.$!; @@ -443,15 +444,15 @@ sub overloaderror { # ------------------------------ Find server with least workload from spare.tab sub spareserver { - my ($loadpercent,$userloadpercent) = @_; + my ($loadpercent,$userloadpercent,$want_server_name) = @_; my $tryserver; my $spareserver=''; if ($userloadpercent !~ /\d/) { $userloadpercent=0; } my $lowestserver=$loadpercent > $userloadpercent? $loadpercent : $userloadpercent; - foreach $tryserver (keys %spareid) { - my $loadans=reply('load',$tryserver); - my $userloadans=reply('userload',$tryserver); + foreach $tryserver (keys(%spareid)) { + my $loadans=&reply('load',$tryserver); + my $userloadans=&reply('userload',$tryserver); if ($loadans !~ /\d/ && $userloadans !~ /\d/) { next; #didn't get a number from the server } @@ -468,7 +469,11 @@ sub spareserver { $answer = $userloadans; } if (($answer =~ /\d/) && ($answer<$lowestserver)) { - $spareserver="http://$hostname{$tryserver}"; + if ($want_server_name) { + $spareserver=$tryserver; + } else { + $spareserver="http://$hostname{$tryserver}"; + } $lowestserver=$answer; } } @@ -767,6 +772,13 @@ sub validate_access_key { } # ------------------------------------- Find the section of student in a course +sub devalidate_getsection_cache { + my ($udom,$unam,$courseid)=@_; + $courseid=~s/\_/\//g; + $courseid=~s/^(\w)/\/$1/; + my $hashid="$udom:$unam:$courseid"; + &devalidate_cache_new('getsection',$hashid); +} sub getsection { my ($udom,$unam,$courseid)=@_; @@ -1053,7 +1065,7 @@ sub repcopy { if ($response->is_error()) { unlink($transname); my $message=$response->status_line; - &logthis("WARNING:" + &logthis("WARNING:" ." LWP get: $message: $filename"); return 'unavailable'; } else { @@ -1063,7 +1075,7 @@ sub repcopy { if ($mresponse->is_error()) { unlink($filename.'.meta'); &logthis( - "INFO: No metadata: $filename"); + "INFO: No metadata: $filename"); } } rename($transname,$filename); @@ -1132,7 +1144,7 @@ sub allowuploaded { } # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course -# input: action, courseID, current domain, home server for course, intended +# input: action, courseID, current domain, intended # path to file, source of file, instruction to parse file for objects, # ref to hash for embedded objects, # ref to hash for codebase of java objects. @@ -1162,13 +1174,13 @@ sub allowuploaded { # sub process_coursefile { - my ($action,$docuname,$docudom,$docuhome,$file,$source,$parser,$allfiles,$codebase)=@_; + my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_; my $fetchresult; + my $home=&homeserver($docuname,$docudom); if ($action eq 'propagate') { - $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file - ,$docuhome); + $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, + $home); } else { - my $fetchresult = ''; my $fpath = ''; my $fname = $file; ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); @@ -1182,7 +1194,7 @@ sub process_coursefile { my $destination = $filepath.'/'.$fname; rename($source,$destination); $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, - $docuhome); + $home); } } elsif ($action eq 'uploaddoc') { open(my $fh,'>'.$filepath.'/'.$fname); @@ -1195,19 +1207,19 @@ sub process_coursefile { } } $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, - $docuhome); + $home); if ($fetchresult eq 'ok') { return '/uploaded/'.$fpath.'/'.$fname; } else { &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. - ' to host '.$docuhome.': '.$fetchresult); + ' to host '.$home.': '.$fetchresult); return '/adm/notfound.html'; } } } unless ( $fetchresult eq 'ok') { &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. - ' to host '.$docuhome.': '.$fetchresult); + ' to host '.$home.': '.$fetchresult); } return $fetchresult; } @@ -1228,7 +1240,7 @@ sub build_filepath { } sub store_edited_file { - my ($primary_url,$content,$docudom,$docuname,$docuhome,$fetchresult) = @_; + my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_; my $file = $primary_url; $file =~ s#^/uploaded/$docudom/$docuname/##; my $fpath = ''; @@ -1239,12 +1251,14 @@ sub store_edited_file { open(my $fh,'>'.$filepath.'/'.$fname); print $fh $content; close($fh); + my $home=&homeserver($docuname,$docudom); $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, - $docuhome); + $home); if ($$fetchresult eq 'ok') { return '/uploaded/'.$fpath.'/'.$fname; } else { - &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. ' to host '.$docuhome.': '.$$fetchresult); + &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. + ' to host '.$home.': '.$$fetchresult); return '/adm/notfound.html'; } } @@ -1295,30 +1309,30 @@ sub userfileupload { return $fullpath.'/'.$fname; } # Create the directory if not present - 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'}; - $docuhome=$env{'course.'.$env{'request.course.id'}.'.home'}; - if ($env{'form.folder'} =~ m/^default/) { - return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase); + my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; + my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; + if ($env{'form.folder'} =~ m/^(default|supplemental)/) { + return &finishuserfileupload($docuname,$docudom, + $formname,$fname,$parser,$allfiles, + $codebase); } else { $fname=$env{'form.folder'}.'/'.$fname; - return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname,$parser,$allfiles,$codebase); + return &process_coursefile('uploaddoc',$docuname,$docudom, + $fname,$formname,$parser, + $allfiles,$codebase); } } else { - $docuname=$env{'user.name'}; - $docudom=$env{'user.domain'}; - $docuhome=$env{'user.home'}; - return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase); + my $docuname=$env{'user.name'}; + my $docudom=$env{'user.domain'}; + return &finishuserfileupload($docuname,$docudom,$formname, + $fname,$parser,$allfiles,$codebase); } } sub finishuserfileupload { - my ($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase) = @_; + my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; my ($fnamepath,$file); @@ -1342,13 +1356,16 @@ sub finishuserfileupload { close(FH); } if ($parser eq 'parse') { - my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,$codebase); + my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, + $codebase); unless ($parse_result eq 'ok') { - &logthis('Failed to parse '.$filepath.$file.' for embedded media: '.$parse_result); + &logthis('Failed to parse '.$filepath.$file. + ' for embedded media: '.$parse_result); } } # Notify homeserver to grep it # + my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { # @@ -1362,7 +1379,7 @@ sub finishuserfileupload { } sub extract_embedded_items { - my ($filepath,$file,$allfiles,$codebase) = @_; + my ($filepath,$file,$allfiles,$codebase,$content) = @_; my @state = (); my %javafiles = ( codebase => '', @@ -1373,118 +1390,99 @@ sub extract_embedded_items { src => '', movie => '', ); - my $p = HTML::Parser->new - ( - xml_mode => 1, - start_h => - [sub { - my ($tagname, $attr) = @_; - push (@state, $tagname); - if (lc($tagname) eq 'img') { - if (exists($$allfiles{$attr->{'src'}})) { - unless (grep/^src$/,@{$$allfiles{$attr->{'src'}}}) { - push (@{$$allfiles{$attr->{'src'}}},&escape('src')); - } - } else { - @{$$allfiles{$attr->{'src'}}} = (&escape('src')); - } - } - if (lc($tagname) eq 'object') { - foreach my $item (keys (%javafiles)) { - $javafiles{$item} = ''; - } - } - if (lc($state[-2]) eq 'object') { - if (lc($tagname) eq 'param') { - my $name = lc($attr->{'name'}); - foreach my $item (keys (%mediafiles)) { - if ($name eq $item) { - if (exists($$allfiles{$attr->{'value'}})) { - unless(grep/^value$/,@{$$allfiles{$attr->{'value'}}}) { - push(@{$$allfiles{$attr->{'value'}}},&escape('value')); - } - } else { - @{$$allfiles{$attr->{'value'}}} = (&escape('value')); - } - last; - } - } - foreach my $item (keys (%javafiles)) { - if ($name eq $item) { - $javafiles{$item} = $attr->{'value'}; - last; - } - } - } - } - if (lc($tagname) eq 'embed') { - unless (lc($state[-2]) eq 'object') { - foreach my $item (keys (%javafiles)) { - $javafiles{$item} = ''; - } - } - foreach my $item (keys (%javafiles)) { - if ($attr->{$item}) { - $javafiles{$item} = $attr->{$item}; - last; - } - } - foreach my $item (keys (%mediafiles)) { - if ($attr->{$item}) { - if (exists($$allfiles{$attr->{$item}})) { - unless (grep/^$item$/,@{$$allfiles{$item}}) { - push(@{$$allfiles{$attr->{$item}}},&escape($item)); - } - } else { - @{$$allfiles{$attr->{$item}}} = (&escape($item)); - } - last; - } - } - } - }, "tagname, attr"], - text_h => - [sub { - my ($text) = @_; - }, "dtext"], - end_h => - [sub { - my ($tagname) = @_; - unless ($javafiles{'codebase'} eq '') { - $javafiles{'codebase'} .= '/'; - } - if (lc($tagname) eq 'object') { - &extract_java_items(\%javafiles,$allfiles,$codebase); - } - if (lc($tagname) eq 'embed') { - unless (lc($state[-2]) eq 'object') { - &extract_java_items(\%javafiles,$allfiles,$codebase); - } - } - pop @state; - }, "tagname"], - ); - $p->parse_file($filepath.'/'.$file); - $p->eof; - return 'ok'; -} - -sub extract_java_items { - my ($javafiles,$allfiles,$codebase) = @_; - foreach my $item (keys (%{$javafiles})) { - unless ($item eq 'codebase') { - if ($$javafiles{$item} ne '') { - if (exists($$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}})) { - unless (grep/^$item$/,@{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}}) { - push(@{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}},&escape($item)); - } + my $p; + if ($content) { + $p = HTML::LCParser->new($content); + } else { + $p = HTML::LCParser->new($filepath.'/'.$file); + } + while (my $t=$p->get_token()) { + if ($t->[0] eq 'S') { + my ($tagname, $attr) = ($t->[1],$t->[2]); + push (@state, $tagname); + if (lc($tagname) eq 'allow') { + &add_filetype($allfiles,$attr->{'src'},'src'); + } + if (lc($tagname) eq 'img') { + &add_filetype($allfiles,$attr->{'src'},'src'); + } + if (lc($tagname) eq 'script') { + if ($attr->{'archive'} =~ /\.jar$/i) { + &add_filetype($allfiles,$attr->{'archive'},'archive'); } else { - @{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}} = (&escape($item)); - $$codebase{$$javafiles{'codebase'}.$$javafiles{$item}} = $$javafiles{'codebase'}; - + &add_filetype($allfiles,$attr->{'src'},'src'); } } - } + if (lc($tagname) eq 'link') { + if (lc($attr->{'rel'}) eq 'stylesheet') { + &add_filetype($allfiles,$attr->{'href'},'href'); + } + } + if (lc($tagname) eq 'object' || + (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) { + foreach my $item (keys(%javafiles)) { + $javafiles{$item} = ''; + } + } + if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') { + my $name = lc($attr->{'name'}); + foreach my $item (keys(%javafiles)) { + if ($name eq $item) { + $javafiles{$item} = $attr->{'value'}; + last; + } + } + foreach my $item (keys(%mediafiles)) { + if ($name eq $item) { + &add_filetype($allfiles, $attr->{'value'}, 'value'); + last; + } + } + } + if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') { + foreach my $item (keys(%javafiles)) { + if ($attr->{$item}) { + $javafiles{$item} = $attr->{$item}; + last; + } + } + foreach my $item (keys(%mediafiles)) { + if ($attr->{$item}) { + &add_filetype($allfiles,$attr->{$item},$item); + last; + } + } + } + } elsif ($t->[0] eq 'E') { + my ($tagname) = ($t->[1]); + if ($javafiles{'codebase'} ne '') { + $javafiles{'codebase'} .= '/'; + } + if (lc($tagname) eq 'applet' || + lc($tagname) eq 'object' || + (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object') + ) { + foreach my $item (keys(%javafiles)) { + if ($item ne 'codebase' && $javafiles{$item} ne '') { + my $file=$javafiles{'codebase'}.$javafiles{$item}; + &add_filetype($allfiles,$file,$item); + } + } + } + pop @state; + } + } + return 'ok'; +} + +sub add_filetype { + my ($allfiles,$file,$type)=@_; + if (exists($allfiles->{$file})) { + unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) { + push(@{$allfiles->{$file}}, &escape($type)); + } + } else { + @{$allfiles->{$file}} = (&escape($type)); } } @@ -1545,7 +1543,7 @@ sub flushcourselogs { } else { &logthis('Failed to flush log buffer for '.$crsid); if (length($courselogs{$crsid})>40000) { - &logthis("WARNING: Buffer for ".$crsid. + &logthis("WARNING: Buffer for ".$crsid. " exceeded maximum size, deleting."); delete $courselogs{$crsid}; } @@ -1616,6 +1614,31 @@ sub flushcourselogs { delete $userrolehash{$entry}; } } +# +# Reverse lookup of domain roles (dc, ad, li, sc, au) +# + my %domrolebuffer = (); + foreach my $entry (keys %domainrolehash) { + my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry; + if ($domrolebuffer{$rudom}) { + $domrolebuffer{$rudom}.='&'.&escape($entry). + '='.&escape($domainrolehash{$entry}); + } else { + $domrolebuffer{$rudom}.=&escape($entry). + '='.&escape($domainrolehash{$entry}); + } + delete $domainrolehash{$entry}; + } + foreach my $dom (keys(%domrolebuffer)) { + foreach my $tryserver (keys %libserv) { + if ($hostdom{$tryserver} eq $dom) { + unless (&reply('domroleput:'.$dom.':'. + $domrolebuffer{$dom},$tryserver) eq 'ok') { + &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); + } + } + } + } $dumpcount++; } @@ -1649,7 +1672,7 @@ sub courseacclog { my $fnsymb=shift; unless ($env{'request.course.id'}) { return ''; } my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; - if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { + if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { $what.=':POST'; # FIXME: Probably ought to escape things.... foreach (keys %env) { @@ -1691,14 +1714,24 @@ sub linklog { sub userrolelog { my ($trole,$username,$domain,$area,$tstart,$tend)=@_; - if (($trole=~/^ca/) || ($trole=~/^in/) || - ($trole=~/^cc/) || ($trole=~/^ep/) || - ($trole=~/^cr/) || ($trole=~/^ta/)) { + if (($trole=~/^ca/) || ($trole=~/^aa/) || + ($trole=~/^in/) || ($trole=~/^cc/) || + ($trole=~/^ep/) || ($trole=~/^cr/) || + ($trole=~/^ta/)) { my (undef,$rudom,$runame,$rsec)=split(/\//,$area); $userrolehash {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} =$tend.':'.$tstart; - } + } + if (($trole=~/^dc/) || ($trole=~/^ad/) || + ($trole=~/^li/) || ($trole=~/^li/) || + ($trole=~/^au/) || ($trole=~/^dg/) || + ($trole=~/^sc/)) { + my (undef,$rudom,$runame,$rsec)=split(/\//,$area); + $domainrolehash + {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} + = $tend.':'.$tstart; + } } sub get_course_adv_roles { @@ -1722,7 +1755,11 @@ sub get_course_adv_roles { if ($username eq '' || $domain eq '') { next; } if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } + if ($role eq 'cr') { next; } my $key=&plaintext($role); + if ($role =~ /^cr/) { + $key=(split('/',$role))[3]; + } if ($section) { $key.=' (Sec/Grp '.$section.')'; } if ($returnhash{$key}) { $returnhash{$key}.=','.$username.':'.$domain; @@ -1813,7 +1850,65 @@ sub courseiddump { return %returnhash; } -# +# ---------------------------------------------------------- DC e-mail + +sub dcmailput { + my ($domain,$msgid,$contents,$server)=@_; + my $status = &Apache::lonnet::critical( + 'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='. + &Apache::lonnet::escape($$contents{$server}),$server); + return $status; +} + +sub dcmaildump { + my ($dom,$startdate,$enddate,$senders) = @_; + my %returnhash=(); + foreach my $tryserver (keys(%libserv)) { + if ($hostdom{$tryserver} eq $dom) { + %{$returnhash{$tryserver}}=(); + my $cmd='dcmaildump:'.$dom.':'. + &escape($startdate).':'.&escape($enddate).':'; + my @esc_senders=map { &escape($_)} @$senders; + $cmd.=&escape(join('&',@esc_senders)); + foreach (split(/\&/,&reply($cmd,$tryserver))) { + my ($key,$value) = split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{$tryserver}{&unescape($key)} = &unescape($value); + } + } + } + } + return %returnhash; +} +# ---------------------------------------------------------- Domain roles + +sub get_domain_roles { + my ($dom,$roles,$startdate,$enddate)=@_; + if (undef($startdate) || $startdate eq '') { + $startdate = '.'; + } + if (undef($enddate) || $enddate eq '') { + $enddate = '.'; + } + my $rolelist = join(':',@{$roles}); + my %personnel = (); + foreach my $tryserver (keys(%libserv)) { + if ($hostdom{$tryserver} eq $dom) { + %{$personnel{$tryserver}}=(); + foreach ( + split(/\&/,&reply('domrolesdump:'.$dom.':'. + &escape($startdate).':'.&escape($enddate).':'. + &escape($rolelist), $tryserver))) { + my($key,$value) = split(/\=/,$_); + if (($key) && ($value)) { + $personnel{$tryserver}{&unescape($key)} = &unescape($value); + } + } + } + } + return %personnel; +} + # ----------------------------------------------------------- Check out an item sub get_first_access { @@ -1859,7 +1954,7 @@ sub checkout { $now.'&'.$ENV{'REMOTE_ADDR'}); my $token=&reply('tmpput:'.$infostr,$lonhost); if ($token=~/^error\:/) { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. ""); return ''; @@ -1875,7 +1970,7 @@ sub checkout { unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { return ''; } else { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. ""); } @@ -1885,7 +1980,7 @@ sub checkout { $token)) ne 'ok') { return ''; } else { - &logthis("WARNING: ". + &logthis("WARNING: ". "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. ""); } @@ -2488,11 +2583,14 @@ sub rolesinit { if ($_!~/^rolesdef_/) { my ($area,$role)=split(/=/,$_); $area=~s/\_\w\w$//; - my ($trole,$tend,$tstart); if ($role=~/^cr/) { - ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); - ($tend,$tstart)=split('_',$trest); + if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { + ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); + ($tend,$tstart)=split('_',$trest); + } else { + $trole=$role; + } } else { ($trole,$tend,$tstart)=split(/_/,$role); } @@ -2508,7 +2606,7 @@ sub rolesinit { &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); } } - } + } } my ($author,$adv) = &set_userprivs(\$userroles,\%allroles); $userroles.='user.adv='.$adv."\n". @@ -2861,6 +2959,29 @@ sub eget { return %returnhash; } +# ------------------------------------------------------------ tmpput interface +sub tmpput { + my ($storehash,$server)=@_; + my $items=''; + foreach (keys(%$storehash)) { + $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + } + $items=~s/\&$//; + return &reply("tmpput:$items",$server); +} + +# ------------------------------------------------------------ tmpget interface +sub tmpget { + my ($token)=@_; + my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'}); + my %returnhash; + foreach my $item (split(/\&/,$rep)) { + my ($key,$value)=split(/=/,$item); + $returnhash{&unescape($key)}=&thaw_unescape($value); + } + return %returnhash; +} + # ---------------------------------------------- Custom access rule evaluation sub customaccess { @@ -2914,7 +3035,7 @@ sub allowed { # Free bre access to user's own portfolio contents my ($space,$domain,$name,$dir)=split('/',$uri); - if (($space=~/^(uploaded|ediupload)$/) && ($env{'user.name'} eq $name) && + if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { return 'F'; } @@ -2982,15 +3103,30 @@ sub allowed { $thisallowed.=$1; } -# URI is an uploaded document for this course +# URI is an uploaded document for this course, default permissions don't matter # not allowing 'edit' access (editupload) to uploaded course docs if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { - my $refuri=$env{'httpref.'.$orguri}; - if ($refuri) { - if ($refuri =~ m|^/adm/|) { - $thisallowed='F'; - } - } + $thisallowed=''; + my ($match)=&is_on_map($uri); + if ($match) { + if ($env{'user.priv.'.$env{'request.role'}.'./'} + =~/\Q$priv\E\&([^\:]*)/) { + $thisallowed.=$1; + } + } else { + my $refuri=$env{'httpref.'.$orguri}; + if ($refuri) { + if ($refuri =~ m|^/adm/|) { + $thisallowed='F'; + } else { + $refuri=&declutter($refuri); + my ($match) = &is_on_map($refuri); + if ($match) { + $thisallowed='F'; + } + } + } + } } # Full access at system, domain or course-wide level? Exit. @@ -3001,7 +3137,16 @@ 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:'=~/\:\Q$priv\E\:/) { + if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) { + if (($priv eq 'cca') || ($priv eq 'caa')) { + my ($audom,$auname)=split('/',$uri); +# no author name given, so this just checks on the general right to make a co-author in this domain + unless ($auname) { return $thisallowed; } +# an author name is given, so we are about to actually make a co-author for a certain account + if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) || + (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) && + ($audom ne $env{'request.role.domain'}))) { return ''; } + } return $thisallowed; } # @@ -3149,7 +3294,7 @@ sub allowed { my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/\Q$rolecode\E/) { - &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $env{'request.course.id'}); return ''; @@ -3157,7 +3302,7 @@ sub allowed { if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} =~/\Q$unamedom\E/) { - &log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. $env{'request.course.id'}); return ''; @@ -3169,8 +3314,8 @@ sub allowed { if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$env{'request.role'}))[0]; 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); + &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); return ''; } } @@ -3197,8 +3342,7 @@ sub allowed { # --------------------------------------------------- Is a resource on the map? sub is_on_map { - my $uri=&declutter(shift); - $uri=~s/\.\d+\.(\w+)$/\.$1/; + my $uri=&deversion(&declutter(shift)); my @uriparts=split(/\//,$uri); my $filename=$uriparts[$#uriparts]; my $pathname=$uri; @@ -3513,7 +3657,7 @@ sub auto_instcode_format { sub plaintext { my $short=shift; - return &mt($prp{$short}); + return &Apache::lonlocal::mt($prp{$short}); } # ----------------------------------------------------------------- Assign Role @@ -3568,7 +3712,7 @@ sub assignrole { my $answer=&reply($command,&homeserver($uname,$udom)); # log new user role if status is ok if ($answer eq 'ok') { - &userrolelog($mrole,$uname,$udom,$url,$start,$end); + &userrolelog($role,$uname,$udom,$url,$start,$end); } return $answer; } @@ -3771,6 +3915,8 @@ sub modify_student_enrollment { $cdom,$cnum); unless (($reply eq 'ok') || ($reply eq 'delayed')) { return 'error: '.$reply; + } else { + &devalidate_getsection_cache($udom,$uname,$cid); } # Add student role to user my $uurl='/'.$cid; @@ -3829,7 +3975,9 @@ sub createcourse { return 'refused'; } # ------------------------------------------------------------------- Create ID - my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). + my $uname=int(1+rand(9)). + ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. + substr($$.time,0,5).unpack("H8",pack("I32",time)). unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; # ----------------------------------------------- Make sure that does not exist my $uhome=&homeserver($uname,$udom,'true'); @@ -3875,7 +4023,7 @@ sub createcourse { ENDINITMAP $topurl=&declutter( - &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + &finishuserfileupload($uname,$udom,'initmap','default.sequence') ); } # ----------------------------------------------------------- Write preferences @@ -4078,28 +4226,25 @@ sub unmark_as_readonly { my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } my @readonly_files = &get_marked_as_readonly($domain,$user,$what); - foreach my $file(@readonly_files){ - my $current_locks = $current_permissions{$file}; + foreach my $file (@readonly_files) { + if (defined($file_name) && ($file_name ne $file)) { next; } + my $current_locks = $current_permissions{$file}; my @new_locks; my @del_keys; if (ref($current_locks) eq "ARRAY"){ foreach my $locker (@{$current_locks}) { my $compare=$locker; if (ref($locker)) { $compare=join('',@{$locker}) }; - if ($compare eq $symb_crs) { - if (defined($file_name) && ($file_name ne $file)) { - push(@new_locks, $what); - } - } else { - push(@new_locks, $what); + if ($compare ne $symb_crs) { + push(@new_locks, $locker); } } - if (@new_locks > 0) { + if (scalar(@new_locks) > 0) { $current_permissions{$file} = \@new_locks; } else { push(@del_keys, $file); &del('file_permissions',\@del_keys, $domain, $user); - delete $current_permissions{$file}; + delete($current_permissions{$file}); } } } @@ -4340,7 +4485,7 @@ sub get_userresdata { } #error 2 occurs when the .db doesn't exist if ($tmp!~/error: 2 /) { - &logthis("WARNING:". + &logthis("WARNING:". " Trying to get resource data for ". $uname." at ".$udom.": ". $tmp.""); @@ -4427,8 +4572,10 @@ sub EXT { if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { - if (defined($Apache::lonhomework::parsing_a_problem) || - defined($Apache::lonhomework::parsing_a_task)) { + if ( (defined($Apache::lonhomework::parsing_a_problem) + || defined($Apache::lonhomework::parsing_a_task)) + && + ($symbparm eq &symbread()) ) { return $Apache::lonhomework::history{$qualifierrest}; } else { my %restored; @@ -4492,7 +4639,7 @@ sub EXT { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { if ($qualifier eq 'textremote') { - if (&mt('textual_remote_display') eq 'on') { + if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') { return 1; } else { return 0; @@ -4909,7 +5056,7 @@ sub metadata_generate_part0 { '.type'}; my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. '.display'}; - my $expr='\\[Part: '.$allnames{$name}.'\\]'; + my $expr='[Part: '.$allnames{$name}.']'; $olddis=~s/\Q$expr\E/\[Part: 0\]/; $$metacache{"$key.display"}=$olddis; } @@ -5014,7 +5161,7 @@ sub symbverify { if ($ids) { # ------------------------------------------------------------------- Has ID(s) foreach (split(/\,/,$ids)) { - my ($mapid,$resid)=split(/\./,$_); + my ($mapid,$resid)=split(/\./,$_); if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { @@ -5233,8 +5380,37 @@ sub numval3 { return $total; } +sub digest { + my ($data)=@_; + my $digest=&Digest::MD5::md5($data); + my ($a,$b,$c,$d)=unpack("iiii",$digest); + my ($e,$f); + { + use integer; + $e=($a+$b); + $f=($c+$d); + if ($_64bit) { + $e=(($e<<32)>>32); + $f=(($f<<32)>>32); + } + } + if (wantarray) { + return ($e,$f); + } else { + my $g; + { + use integer; + $g=($e+$f); + if ($_64bit) { + $g=(($g<<32)>>32); + } + } + return $g; + } +} + sub latest_rnd_algorithm_id { - return '64bit4'; + return '64bit5'; } sub get_rand_alg { @@ -5274,11 +5450,15 @@ sub rndseed { if (!$username) { $username=$wusername } my $which=&get_rand_alg(); if (defined(&getCODE())) { - if ($which eq '64bit4') { + if ($which eq '64bit5') { + return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); + } elsif ($which eq '64bit4') { return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); } else { return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); } + } elsif ($which eq '64bit5') { + return &rndseed_64bit5($symb,$courseid,$domain,$username); } elsif ($which eq '64bit4') { return &rndseed_64bit4($symb,$courseid,$domain,$username); } elsif ($which eq '64bit3') { @@ -5401,6 +5581,12 @@ sub rndseed_64bit4 { } } +sub rndseed_64bit5 { + my ($symb,$courseid,$domain,$username)=@_; + my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username"); + return "$num1:$num2"; +} + sub rndseed_CODE_64bit { my ($symb,$courseid,$domain,$username)=@_; { @@ -5439,6 +5625,13 @@ sub rndseed_CODE_64bit4 { } } +sub rndseed_CODE_64bit5 { + my ($symb,$courseid,$domain,$username)=@_; + my $code = &getCODE(); + my ($num1,$num2)=&digest("$symb,$courseid,$code"); + return "$num1:$num2"; +} + sub setup_random_from_rndseed { my ($rndseed)=@_; if ($rndseed =~/([,:])/) { @@ -5648,6 +5841,9 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~m:^/home/[^/]*/public_html/:) { + # is a correct contruction space reference + $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); @@ -5680,14 +5876,15 @@ sub filelocation { sub hreflocation { my ($dir,$file)=@_; unless (($file=~m-^http://-i) || ($file=~m-^/-)) { - my $finalpath=filelocation($dir,$file); - $finalpath=~s-^/home/httpd/html--; - $finalpath=~s-^/home/(\w+)/public_html/-/~$1/-; - return $finalpath; - } elsif ($file=~m-^/home-) { - $file=~s-^/home/httpd/html--; + $file=filelocation($dir,$file); + } + if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { + $file=~s-^\Q$perlvar{'lonDocRoot'}\E--; + } elsif ($file=~m-/home/(\w+)/public_html/-) { $file=~s-^/home/(\w+)/public_html/-/~$1/-; - return $file; + } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { + $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/ + -/uploaded/$1/$2/-x; } return $file; } @@ -5889,14 +6086,21 @@ BEGIN { sub get_iphost { if (%iphost) { return %iphost; } + my %name_to_ip; foreach my $id (keys(%hostname)) { my $name=$hostname{$id}; - my $ip = gethostbyname($name); - if (!$ip || length($ip) ne 4) { - &logthis("Skipping host $id name $name no IP found\n"); - next; + my $ip; + if (!exists($name_to_ip{$name})) { + $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found\n"); + next; + } + $ip=inet_ntoa($ip); + $name_to_ip{$name} = $ip; + } else { + $ip = $name_to_ip{$name}; } - $ip=inet_ntoa($ip); push(@{$iphost{$ip}},$id); } return %iphost; @@ -5971,7 +6175,7 @@ $processmarker='_'.time.'_'.$perlvar{'lo $dumpcount=0; &logtouch(); -&logthis('INFO: Read configuration'); +&logthis('INFO: Read configuration'); $readit=1; { use integer; @@ -6798,7 +7002,6 @@ userspace, probably shouldn't be called docuname: username or courseid of destination for the file docudom: domain of user/course of destination for the file - docuhome: loncapa id of the library server that is getting the file formname: same as for userfileupload() fname: filename (inculding subdirectories) for the file