--- loncom/lonnet/perl/lonnet.pm 2006/05/16 18:50:55 1.738 +++ loncom/lonnet/perl/lonnet.pm 2006/09/28 21:24:56 1.786 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.738 2006/05/16 18:50:55 albertel Exp $ +# $Id: lonnet.pm,v 1.786 2006/09/28 21:24:56 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -38,7 +38,7 @@ use vars qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom %libserv %pr %prp $memcache %packagetab %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary $tmpdir $_64bit %env); @@ -52,6 +52,9 @@ use Storable qw(lock_store lock_nstore l use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; use Digest::MD5; +use lib '/home/httpd/lib/perl'; +use LONCAPA; +use LONCAPA::Configuration; my $readit; my $max_connection_retries = 10; # Or some such value. @@ -278,9 +281,50 @@ sub critical { return $answer; } -# ------------------------------------------- Transfer profile into environment +# ------------------------------------------- check if return value is an error + +sub error { + my ($result) = @_; + if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) { + if ($2 == 2) { return undef; } + return $1; + } + return undef; +} + +sub convert_and_load_session_env { + my ($lonidsdir,$handle)=@_; + my @profile; + { + open(my $idf,"$lonidsdir/$handle.id"); + flock($idf,LOCK_SH); + @profile=<$idf>; + close($idf); + } + my %temp_env; + foreach my $line (@profile) { + if ($line !~ m/=/) { + return 0; + } + chomp($line); + my ($envname,$envvalue)=split(/=/,$line,2); + $temp_env{&unescape($envname)} = &unescape($envvalue); + } + unlink("$lonidsdir/$handle.id"); + if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(), + 0640)) { + %disk_env = %temp_env; + @env{keys(%temp_env)} = @disk_env{keys(%temp_env)}; + untie(%disk_env); + } + return 1; +} +# ------------------------------------------- Transfer profile into environment +my $env_loaded; sub transfer_profile_to_env { + if ($env_loaded) { return; } + my ($lonidsdir,$handle)=@_; if (!defined($lonidsdir)) { $lonidsdir = $perlvar{'lonIDsDir'}; @@ -289,29 +333,36 @@ sub transfer_profile_to_env { ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); } - my @profile; + my $convert; { - open(my $idf,"$lonidsdir/$handle.id"); + open(my $idf,"$lonidsdir/$handle.id"); flock($idf,LOCK_SH); - @profile=<$idf>; - close($idf); + if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", + &GDBM_READER(),0640)) { + @env{keys(%disk_env)} = @disk_env{keys(%disk_env)}; + untie(%disk_env); + } else { + $convert = 1; + } + } + if ($convert) { + if (!&convert_and_load_session_env($lonidsdir,$handle)) { + &logthis("Failed to load session, or convert session."); + } } - my $envi; - my %Remove; - for ($envi=0;$envi<=$#profile;$envi++) { - chomp($profile[$envi]); - my ($envname,$envvalue)=split(/=/,$profile[$envi],2); - $envname=&unescape($envname); - $envvalue=&unescape($envvalue); - $env{$envname} = $envvalue; + + my %remove; + while ( my $envname = each(%env) ) { if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { - $Remove{$key}++; + $remove{$key}++; } } } + $env{'user.environment'} = "$lonidsdir/$handle.id"; - foreach my $expired_key (keys(%Remove)) { + $env_loaded=1; + foreach my $expired_key (keys(%remove)) { &delenv($expired_key); } } @@ -330,51 +381,13 @@ sub appenv { $env{$key}=$newenv{$key}; } } - - my $lockfh; - unless (open($lockfh,"$env{'user.environment'}")) { - return 'error: '.$!; - } - unless (flock($lockfh,LOCK_EX)) { - &logthis("WARNING: ". - 'Could not obtain exclusive lock in appenv: '.$!); - close($lockfh); - return 'error: '.$!; - } - - my @oldenv; - { - my $fh; - unless (open($fh,"$env{'user.environment'}")) { - return 'error: '.$!; + if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), + 0640)) { + while (my ($key,$value) = each(%newenv)) { + $disk_env{$key} = $value; } - @oldenv=<$fh>; - close($fh); + untie(%disk_env); } - for (my $i=0; $i<=$#oldenv; $i++) { - chomp($oldenv[$i]); - if ($oldenv[$i] ne '') { - my ($name,$value)=split(/=/,$oldenv[$i],2); - $name=&unescape($name); - $value=&unescape($value); - unless (defined($newenv{$name})) { - $newenv{$name}=$value; - } - } - } - { - my $fh; - unless (open($fh,">$env{'user.environment'}")) { - return 'error'; - } - my $newname; - foreach $newname (keys %newenv) { - print $fh &escape($newname).'='.&escape($newenv{$newname})."\n"; - } - close($fh); - } - - close($lockfh); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -386,43 +399,15 @@ sub delenv { "Attempt to delete from environment ".$delthis); return 'error'; } - my @oldenv; - { - my $fh; - unless (open($fh,"$env{'user.environment'}")) { - return 'error'; - } - unless (flock($fh,LOCK_SH)) { - &logthis("WARNING: ". - 'Could not obtain shared lock in delenv: '.$!); - close($fh); - return 'error: '.$!; - } - @oldenv=<$fh>; - close($fh); - } - { - my $fh; - unless (open($fh,">$env{'user.environment'}")) { - return 'error'; - } - unless (flock($fh,LOCK_EX)) { - &logthis("WARNING: ". - 'Could not obtain exclusive lock in delenv: '.$!); - close($fh); - return 'error: '.$!; - } - foreach my $cur_key (@oldenv) { - my $unescaped_cur_key = &unescape($cur_key); - if ($unescaped_cur_key=~/^$delthis/) { - my ($key) = split('=',$cur_key,2); - $key = &unescape($key); + if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), + 0640)) { + foreach my $key (keys(%disk_env)) { + if ($key=~/^$delthis/) { delete($env{$key}); - } else { - print $fh $cur_key; + delete($disk_env{$key}); } } - close($fh); + untie(%disk_env); } return 'ok'; } @@ -479,41 +464,60 @@ sub overloaderror { sub spareserver { my ($loadpercent,$userloadpercent,$want_server_name) = @_; - my $tryserver; - my $spareserver=''; + my $spare_server; 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); - if ($loadans !~ /\d/ && $userloadans !~ /\d/) { - next; #didn't get a number from the server - } - my $answer; - if ($loadans =~ /\d/) { - if ($userloadans =~ /\d/) { - #both are numbers, pick the bigger one - $answer=$loadans > $userloadans? - $loadans : $userloadans; - } else { - $answer = $loadans; - } - } else { - $answer = $userloadans; - } - if (($answer =~ /\d/) && ($answer<$lowestserver)) { - if ($want_server_name) { - $spareserver=$tryserver; - } else { - $spareserver="http://$hostname{$tryserver}"; - } - $lowestserver=$answer; + my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent + : $userloadpercent; + + foreach my $try_server (@{ $spareid{'primary'} }) { + ($spare_server, $lowest_load) = + &compare_server_load($try_server, $spare_server, $lowest_load); + } + + my $found_server = ($spare_server ne '' && $lowest_load < 100); + + if (!$found_server) { + foreach my $try_server (@{ $spareid{'default'} }) { + ($spare_server, $lowest_load) = + &compare_server_load($try_server, $spare_server, $lowest_load); } } - return $spareserver; + + if (!$want_server_name) { + $spare_server="http://$hostname{$spare_server}"; + } + return $spare_server; } +sub compare_server_load { + my ($try_server, $spare_server, $lowest_load) = @_; + + my $loadans = &reply('load', $try_server); + my $userloadans = &reply('userload',$try_server); + + if ($loadans !~ /\d/ && $userloadans !~ /\d/) { + next; #didn't get a number from the server + } + + my $load; + if ($loadans =~ /\d/) { + if ($userloadans =~ /\d/) { + #both are numbers, pick the bigger one + $load = ($loadans > $userloadans) ? $loadans + : $userloadans; + } else { + $load = $loadans; + } + } else { + $load = $userloadans; + } + + if (($load =~ /\d/) && ($load < $lowest_load)) { + $spare_server = $try_server; + $lowest_load = $load; + } + return ($spare_server,$lowest_load); +} # --------------------------------------------- Try to change a user's password sub changepass { @@ -877,6 +881,7 @@ sub save_cache { &purge_remembered(); #&Apache::loncommon::validate_page(); undef(%env); + undef($env_loaded); } my $to_remember=-1; @@ -1162,7 +1167,7 @@ sub ssi_body { } my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); - $output=~s|//(\s*)?\s||gs; + $output=~s|//(\s*)?\s||gs; $output=~s/^.*?\]*\>//si; $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; return $output; @@ -1170,6 +1175,24 @@ sub ssi_body { # --------------------------------------------------------- Server Side Include +sub absolute_url { + my ($host_name) = @_; + my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); + if ($host_name eq '') { + $host_name = $ENV{'SERVER_NAME'}; + } + return $protocol.$host_name; +} + +sub absolute_url { + my ($host_name) = @_; + my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); + if ($host_name eq '') { + $host_name = $ENV{'SERVER_NAME'}; + } + return $protocol.$host_name; +} + sub ssi { my ($fn,%form)=@_; @@ -1181,10 +1204,10 @@ sub ssi { $form{'no_update_last_known'}=1; if (%form) { - $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); + $request=new HTTP::Request('POST',&absolute_url().$fn); $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); } else { - $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); + $request=new HTTP::Request('GET',&absolute_url().$fn); } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); @@ -1384,7 +1407,22 @@ sub userfileupload { open(my $fh,'>'.$fullpath.'/'.$fname); print $fh $env{'form.'.$formname}; close($fh); - return $fullpath.'/'.$fname; + return $fullpath.'/'.$fname; + } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently + my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}. + '_'.$env{'user.domain'}.'/pending'; + my @parts=split(/\//,$filepath); + my $fullpath = $perlvar{'lonDaemons'}; + for (my $i=0;$i<@parts;$i++) { + $fullpath .= '/'.$parts[$i]; + if ((-e $fullpath)!=1) { + mkdir($fullpath,0777); + } + } + open(my $fh,'>'.$fullpath.'/'.$fname); + print $fh $env{'form.'.$formname}; + close($fh); + return $fullpath.'/'.$fname; } # Create the directory if not present @@ -1648,11 +1686,11 @@ sub flushcourselogs { if ($courseidbuffer{$coursehombuf{$crsid}}) { $courseidbuffer{$coursehombuf{$crsid}}.='&'. &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); } else { $courseidbuffer{$coursehombuf{$crsid}}= &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). - ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}); + ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); } } # @@ -1755,6 +1793,8 @@ sub courselog { $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'}; $courseownerbuf{$env{'request.course.id'}}= $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'}; + $coursetypebuf{$env{'request.course.id'}}= + $env{'course.'.$env{'request.course.id'}.'.type'}; if (defined $courselogs{$env{'request.course.id'}}) { $courselogs{$env{'request.course.id'}}.='&'.$what; } else { @@ -1854,9 +1894,6 @@ sub get_course_adv_roles { (!$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; @@ -1925,7 +1962,7 @@ sub courseidput { } sub courseiddump { - my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref)=@_; + my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_; my %returnhash=(); unless ($domfilter) { $domfilter=''; } foreach my $tryserver (keys %libserv) { @@ -1934,7 +1971,7 @@ sub courseiddump { foreach ( split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. $sincefilter.':'.&escape($descfilter).':'. - &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter), + &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter), $tryserver))) { my ($key,$value)=split(/\=/,$_); if (($key) && ($value)) { @@ -1952,8 +1989,8 @@ sub courseiddump { sub dcmailput { my ($domain,$msgid,$message,$server)=@_; my $status = &Apache::lonnet::critical( - 'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='. - &Apache::lonnet::escape($message),$server); + 'dcmailput:'.$domain.':'.&escape($msgid).'='. + &escape($message),$server); return $status; } @@ -2637,6 +2674,9 @@ sub coursedescription { $returnhash{'home'}= $chome; $returnhash{'domain'} = $cdomain; $returnhash{'num'} = $cnum; + if (!defined($returnhash{'type'})) { + $returnhash{'type'} = 'Course'; + } while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; } @@ -2693,7 +2733,7 @@ sub rolesinit { my %allroles=(); my %allgroups=(); my $now=time; - my $userroles="user.login.time=$now\n"; + my %userroles = ('user.login.time' => $now); my $group_privs; if ($rolesdump ne '') { @@ -2716,7 +2756,9 @@ sub rolesinit { } else { ($trole,$tend,$tstart)=split(/_/,$role); } - $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); + my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain, + $username); + @userroles{keys(%new_role)} = @new_role{keys(%new_role)}; if (($tend!=0) && ($tend<$now)) { $trole=''; } if (($tstart!=0) && ($tstart>$now)) { $trole=''; } if (($area ne '') && ($trole ne '')) { @@ -2732,19 +2774,19 @@ sub rolesinit { } } } - my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups); - $userroles.='user.adv='.$adv."\n". - 'user.author='.$author."\n"; + my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups); + $userroles{'user.adv'} = $adv; + $userroles{'user.author'} = $author; $env{'user.adv'}=$adv; } - return $userroles; + return \%userroles; } sub set_arearole { my ($trole,$area,$tstart,$tend,$domain,$username) = @_; # log the associated role with the area &userrolelog($trole,$username,$domain,$area,$tstart,$tend); - return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n"; + return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend); } sub custom_roleprivs { @@ -2812,7 +2854,7 @@ sub set_userprivs { if (keys(%{$allgroups}) > 0) { foreach my $role (keys %{$allroles}) { my ($trole,$area,$sec,$extendedarea); - if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) { + if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) { $trole = $1; $area = $2; $sec = $3; @@ -2846,7 +2888,7 @@ sub set_userprivs { } my $thesestr=''; foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } - $$userroles.='user.priv.'.$_.'='.$thesestr."\n"; + $userroles->{'user.priv.'.$_} = $thesestr; } return ($author,$adv); } @@ -2897,23 +2939,25 @@ sub del { # -------------------------------------------------------------- dump interface sub dump { - my ($namespace,$udomain,$uname,$regexp,$range)=@_; - if (!$udomain) { $udomain=$env{'user.domain'}; } - if (!$uname) { $uname=$env{'user.name'}; } - my $uhome=&homeserver($uname,$udomain); - if ($regexp) { - $regexp=&escape($regexp); - } else { - $regexp='.'; - } - my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); - my @pairs=split(/\&/,$rep); - my %returnhash=(); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_,2); - $returnhash{unescape($key)}=&thaw_unescape($value); - } - return %returnhash; + my ($namespace,$udomain,$uname,$regexp,$range)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + if ($regexp) { + $regexp=&escape($regexp); + } else { + $regexp='.'; + } + my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + return %returnhash; } # --------------------------------------------------------- dumpstore interface @@ -3182,6 +3226,218 @@ sub tmpdel { return &reply("tmpdel:$token",$server); } +# -------------------------------------------------- portfolio access checking + +sub portfolio_access { + my ($requrl) = @_; + my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); + my $result = &get_portfolio_access($udom,$unum,$file_name,$group); + if ($result eq 'ok') { + return 'F'; + } elsif ($result =~ /^[^:]+:guest_/) { + return 'A'; + } + return ''; +} + +sub get_portfolio_access { + my ($udom,$unum,$file_name,$group,$access_hash) = @_; + + if (!ref($access_hash)) { + my $current_perms = &get_portfile_permissions($udom,$unum); + my %access_controls = &get_access_controls($current_perms,$group, + $file_name); + $access_hash = $access_controls{$file_name}; + } + + my ($public,$guest,@domains,@users,@courses,@groups); + my $now = time; + if (ref($access_hash) eq 'HASH') { + foreach my $key (keys(%{$access_hash})) { + my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); + if ($start > $now) { + next; + } + if ($end && $end<$now) { + next; + } + if ($scope eq 'public') { + $public = $key; + last; + } elsif ($scope eq 'guest') { + $guest = $key; + } elsif ($scope eq 'domains') { + push(@domains,$key); + } elsif ($scope eq 'users') { + push(@users,$key); + } elsif ($scope eq 'course') { + push(@courses,$key); + } elsif ($scope eq 'group') { + push(@groups,$key); + } + } + if ($public) { + return 'ok'; + } + if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { + if ($guest) { + return $guest; + } + } else { + if (@domains > 0) { + foreach my $domkey (@domains) { + if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') { + if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) { + return 'ok'; + } + } + } + } + if (@users > 0) { + foreach my $userkey (@users) { + if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { + return 'ok'; + } + } + } + my %roleshash; + my @courses_and_groups = @courses; + push(@courses_and_groups,@groups); + if (@courses_and_groups > 0) { + my (%allgroups,%allroles); + my ($start,$end,$role,$sec,$group); + foreach my $envkey (%env) { + if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) { + my $cid = $2.'_'.$3; + if ($1 eq 'gr') { + $group = $4; + $allgroups{$cid}{$group} = $env{$envkey}; + } else { + if ($4 eq '') { + $sec = 'none'; + } else { + $sec = $4; + } + $allroles{$cid}{$1}{$sec} = $env{$envkey}; + } + } elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) { + my $cid = $2.'_'.$3; + if ($4 eq '') { + $sec = 'none'; + } else { + $sec = $4; + } + $allroles{$cid}{$1}{$sec} = $env{$envkey}; + } + } + if (keys(%allroles) == 0) { + return; + } + foreach my $key (@courses_and_groups) { + my %content = %{$$access_hash{$key}}; + my $cnum = $content{'number'}; + my $cdom = $content{'domain'}; + my $cid = $cdom.'_'.$cnum; + if (!exists($allroles{$cid})) { + next; + } + foreach my $role_id (keys(%{$content{'roles'}})) { + my @sections = @{$content{'roles'}{$role_id}{'section'}}; + my @groups = @{$content{'roles'}{$role_id}{'group'}}; + my @status = @{$content{'roles'}{$role_id}{'access'}}; + my @roles = @{$content{'roles'}{$role_id}{'role'}}; + foreach my $role (keys(%{$allroles{$cid}})) { + if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) { + foreach my $sec (keys(%{$allroles{$cid}{$role}})) { + if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') { + if (grep/^all$/,@sections) { + return 'ok'; + } else { + if (grep/^$sec$/,@sections) { + return 'ok'; + } + } + } + } + if (keys(%{$allgroups{$cid}}) == 0) { + if (grep/^none$/,@groups) { + return 'ok'; + } + } else { + if (grep/^all$/,@groups) { + return 'ok'; + } + foreach my $group (keys(%{$allgroups{$cid}})) { + if (grep/^$group$/,@groups) { + return 'ok'; + } + } + } + } + } + } + } + } + if ($guest) { + return $guest; + } + } + } + return; +} + +sub course_group_datechecker { + my ($dates,$now,$status) = @_; + my ($start,$end) = split(/\./,$dates); + if (!$start && !$end) { + return 'ok'; + } + if (grep/^active$/,@{$status}) { + if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) { + return 'ok'; + } + } + if (grep/^previous$/,@{$status}) { + if ($end > $now ) { + return 'ok'; + } + } + if (grep/^future$/,@{$status}) { + if ($start > $now) { + return 'ok'; + } + } + return; +} + +sub parse_portfolio_url { + my ($url) = @_; + + my ($type,$udom,$unum,$group,$file_name); + + if ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) { + $type = 1; + $udom = $1; + $unum = $2; + $file_name = $3; + } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) { + $type = 2; + $udom = $1; + $unum = $2; + $group = $3; + $file_name = $3.'/'.$4; + } + if (wantarray) { + return ($type,$udom,$unum,$file_name,$group); + } + return $type; +} + +sub is_portfolio_url { + my ($url) = @_; + return scalar(&parse_portfolio_url($url)); +} + # ---------------------------------------------- Custom access rule evaluation sub customaccess { @@ -3227,8 +3483,9 @@ sub allowed { if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources - if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) - || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { + if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) + || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) + && ($priv eq 'bre')) { return 'F'; } @@ -3239,7 +3496,7 @@ sub allowed { return 'F'; } -# bre access to group if user has rgf priv for this group and course. +# bre access to group portfolio for rgf priv in group, or mdg or vcg in course. if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) { if (exists($env{'request.course.id'})) { @@ -3251,6 +3508,14 @@ sub allowed { if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid .'/'.$dir[1]} =~/rgf\&([^\:]*)/) { return $1; + } else { + if ($env{'request.course.sec'}) { + $courseprivid.='/'.$env{'request.course.sec'}; + } + if ($env{'user.priv.'.$env{'request.role'}.'./'. + $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) { + return $2; + } } } } @@ -3319,14 +3584,6 @@ sub allowed { $thisallowed.=$1; } -# Group: uri itself is a group - my $groupuri=$uri; - $groupuri=~s/^([^\/])/\/$1/; - if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri} - =~/\Q$priv\E\&([^\:]*)/) { - $thisallowed.=$1; - } - # 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/|)) { @@ -3353,6 +3610,13 @@ sub allowed { } } + if ($priv eq 'bre' + && $thisallowed ne 'F' + && $thisallowed ne '2' + && &is_portfolio_url($uri)) { + $thisallowed = &portfolio_access($uri); + } + # Full access at system, domain or course-wide level? Exit. if ($thisallowed=~/F/) { @@ -3503,7 +3767,11 @@ sub allowed { # unless ($env{'request.course.id'}) { - return '1'; + if ($thisallowed eq 'A') { + return 'A'; + } else { + return '1'; + } } # @@ -3566,6 +3834,9 @@ sub allowed { } } + if ($thisallowed eq 'A') { + return 'A'; + } return 'F'; } @@ -3812,7 +4083,7 @@ sub auto_run { my $response = &reply('autorun:'.$cdom,$homeserver); return $response; } - + sub auto_get_sections { my ($cnum,$cdom,$inst_coursecode) = @_; my $homeserver = &homeserver($cnum,$cdom); @@ -3823,21 +4094,21 @@ sub auto_get_sections { } return @secs; } - + sub auto_new_course { my ($cnum,$cdom,$inst_course_id,$owner) = @_; my $homeserver = &homeserver($cnum,$cdom); my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); return $response; } - + sub auto_validate_courseID { my ($cnum,$cdom,$inst_course_id) = @_; my $homeserver = &homeserver($cnum,$cdom); my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); return $response; } - + sub auto_create_password { my ($cnum,$cdom,$authparam) = @_; my $homeserver = &homeserver($cnum,$cdom); @@ -3931,33 +4202,49 @@ sub auto_photoupdate { sub auto_instcode_format { my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_; my $courses = ''; - my $homeserver; + my @homeservers; if ($caller eq 'global') { foreach my $tryserver (keys %libserv) { if ($hostdom{$tryserver} eq $codedom) { - $homeserver = $tryserver; - last; + if (!grep/^\Q$tryserver\E$/,@homeservers) { + push(@homeservers,$tryserver); + } } } - if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) { - $homeserver = &homeserver($env{'user.name'},$codedom); - } } else { - $homeserver = &homeserver($caller,$codedom); + push(@homeservers,&homeserver($caller,$codedom)); } foreach (keys %{$instcodes}) { $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; } chop($courses); - my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); - unless ($response =~ /(con_lost|error|no_such_host|refused)/) { - my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; - %{$codes} = &str2hash($codes_str); - @{$codetitles} = &str2array($codetitles_str); - %{$cat_titles} = &str2hash($cat_titles_str); - %{$cat_order} = &str2hash($cat_order_str); + my $ok_response = 0; + my $response; + while (@homeservers > 0 && $ok_response == 0) { + my $server = shift(@homeservers); + $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); + if ($response !~ /(con_lost|error|no_such_host|refused)/) { + my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = + split/:/,$response; + %{$codes} = (%{$codes},&str2hash($codes_str)); + push(@{$codetitles},&str2array($codetitles_str)); + %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); + %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str)); + $ok_response = 1; + } + } + if ($ok_response) { return 'ok'; + } else { + return $response; } +} + +sub auto_validate_class_sec { + my ($cdom,$cnum,$owner,$inst_class) = @_; + my $homeserver = &homeserver($cnum,$cdom); + my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. + &escape($owner).':'.$cdom,$homeserver); return $response; } @@ -3982,7 +4269,6 @@ sub modify_group_roles { if ($result eq 'ok') { &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); } - return $result; } @@ -4075,8 +4361,28 @@ sub devalidate_getgroups_cache { # ------------------------------------------------------------------ Plain Text sub plaintext { - my $short=shift; - return &Apache::lonlocal::mt($prp{$short}); + my ($short,$type,$cid) = @_; + if ($short =~ /^cr/) { + return (split('/',$short))[-1]; + } + if (!defined($cid)) { + $cid = $env{'request.course.id'}; + } + if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { + return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. + '.plaintext'}); + } + my %rolenames = ( + Course => 'std', + Group => 'alt1', + ); + if (defined($type) && + defined($rolenames{$type}) && + defined($prp{$short}{$rolenames{$type}})) { + return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); + } else { + return &Apache::lonlocal::mt($prp{$short}{'std'}); + } } # ----------------------------------------------------------------- Assign Role @@ -4125,6 +4431,8 @@ sub assignrole { $command.='_0_'.$start; } } + my $origstart = $start; + my $origend = $end; # actually delete if ($deleteflag) { if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { @@ -4142,6 +4450,11 @@ sub assignrole { # log new user role if status is ok if ($answer eq 'ok') { &userrolelog($role,$uname,$udom,$url,$start,$end); +# for course roles, perform group memberships changes triggered by role change. + unless ($role =~ /^gr/) { + &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, + $origstart); + } } return $answer; } @@ -4398,7 +4711,8 @@ sub writecoursepref { # ---------------------------------------------------------- Make/modify course sub createcourse { - my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_; + my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, + $course_owner,$crstype)=@_; $url=&declutter($url); my $cid=''; unless (&allowed('ccc',$udom)) { @@ -4435,7 +4749,8 @@ sub createcourse { # ----------------------------------------------------------------- Course made # log existence &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). - ':'.&escape($inst_code).':'.&escape($course_owner),$uhome); + ':'.&escape($inst_code).':'.&escape($course_owner).':'. + &escape($crstype),$uhome); &flushcourselogs(); # set toplevel url my $topurl=$url; @@ -4505,14 +4820,28 @@ sub is_locked { $env{'user.domain'},$env{'user.name'}); my ($tmp)=keys(%locked); if ($tmp=~/^error:/) { undef(%locked); } - + if (ref($locked{$file_name}) eq 'ARRAY') { - $is_locked = 'true'; + $is_locked = 'false'; + foreach my $entry (@{$locked{$file_name}}) { + if (ref($entry) eq 'ARRAY') { + $is_locked = 'true'; + last; + } + } } else { $is_locked = 'false'; } } +sub declutter_portfile { + my ($file) = @_; + &logthis("got $file"); + $file =~ s-^(/portfolio/|portfolio/)-/-; + &logthis("ret $file"); + return $file; +} + # ------------------------------------------------------------- Mark as Read Only sub mark_as_readonly { @@ -4521,6 +4850,7 @@ sub mark_as_readonly { my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } foreach my $file (@{$files}) { + $file = &declutter_portfile($file); push(@{$current_permissions{$file}},$what); } &put('file_permissions',\%current_permissions,$domain,$user); @@ -4596,49 +4926,195 @@ sub files_not_in_path { return (@return_files); } -#--------------------------------------------------------------Get Marked as Read Only +#----------------------------------------------Get portfolio file permissions - -sub get_marked_as_readonly { - my ($domain,$user,$what) = @_; +sub get_portfile_permissions { + my ($domain,$user) = @_; my %current_permissions = &dump('file_permissions',$domain,$user); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } + return \%current_permissions; +} + +#---------------------------------------------Get portfolio file access controls + +sub get_access_controls { + my ($current_permissions,$group,$file) = @_; + my %access; + my $real_file = $file; + $file =~ s/\.meta$//; + if (defined($file)) { + if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') { + foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) { + $access{$real_file}{$control} = $$current_permissions{$file."\0".$control}; + } + } + } else { + foreach my $key (keys(%{$current_permissions})) { + if ($key =~ /\0accesscontrol$/) { + if (defined($group)) { + if ($key !~ m-^\Q$group\E/-) { + next; + } + } + my ($fullpath) = split(/\0/,$key); + if (ref($$current_permissions{$key}) eq 'HASH') { + foreach my $control (keys(%{$$current_permissions{$key}})) { + $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control}; + } + } + } + } + } + return %access; +} + +sub modify_access_controls { + my ($file_name,$changes,$domain,$user)=@_; + my ($outcome,$deloutcome); + my %store_permissions; + my %new_values; + my %new_control; + my %translation; + my @deletions = (); + my $now = time; + if (exists($$changes{'activate'})) { + if (ref($$changes{'activate'}) eq 'HASH') { + my @newitems = sort(keys(%{$$changes{'activate'}})); + my $numnew = scalar(@newitems); + for (my $i=0; $i<$numnew; $i++) { + my $newkey = $newitems[$i]; + my $newid = &Apache::loncommon::get_cgi_id(); + $newkey =~ s/^(\d+)/$newid/; + $translation{$1} = $newid; + $new_values{$file_name."\0".$newkey} = + $$changes{'activate'}{$newitems[$i]}; + $new_control{$newkey} = $now; + } + } + } + my %todelete; + my %changed_items; + foreach my $action ('delete','update') { + if (exists($$changes{$action})) { + if (ref($$changes{$action}) eq 'HASH') { + foreach my $key (keys(%{$$changes{$action}})) { + my ($itemnum) = ($key =~ /^([^:]+):/); + if ($action eq 'delete') { + $todelete{$itemnum} = 1; + } else { + $changed_items{$itemnum} = $key; + } + } + } + } + } + # get lock on access controls for file. + my $lockhash = { + $file_name."\0".'locked_access_records' => $env{'user.name'}. + ':'.$env{'user.domain'}, + }; + my $tries = 0; + my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); + + while (($gotlock ne 'ok') && $tries <3) { + $tries ++; + sleep 1; + $gotlock = &newput('file_permissions',$lockhash,$domain,$user); + } + if ($gotlock eq 'ok') { + my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name); + my ($tmp)=keys(%curr_permissions); + if ($tmp=~/^error:/) { undef(%curr_permissions); } + if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) { + my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'}; + if (ref($curr_controls) eq 'HASH') { + foreach my $control_item (keys(%{$curr_controls})) { + my ($itemnum) = ($control_item =~ /^([^:]+):/); + if (defined($todelete{$itemnum})) { + push(@deletions,$file_name."\0".$control_item); + } else { + if (defined($changed_items{$itemnum})) { + $new_control{$changed_items{$itemnum}} = $now; + push(@deletions,$file_name."\0".$control_item); + $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}}; + } else { + $new_control{$control_item} = $$curr_controls{$control_item}; + } + } + } + } + } + $deloutcome = &del('file_permissions',\@deletions,$domain,$user); + $new_values{$file_name."\0".'accesscontrol'} = \%new_control; + $outcome = &put('file_permissions',\%new_values,$domain,$user); + # remove lock + my @del_lock = ($file_name."\0".'locked_access_records'); + my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); + } else { + $outcome = "error: could not obtain lockfile\n"; + } + return ($outcome,$deloutcome,\%new_values,\%translation); +} + +#------------------------------------------------------Get Marked as Read Only + +sub get_marked_as_readonly { + my ($domain,$user,$what,$group) = @_; + my $current_permissions = &get_portfile_permissions($domain,$user); my @readonly_files; my $cmp1=$what; if (ref($what)) { $cmp1=join('',@{$what}) }; - while (my ($file_name,$value) = each(%current_permissions)) { + while (my ($file_name,$value) = each(%{$current_permissions})) { + if (defined($group)) { + if ($file_name !~ m-^\Q$group\E/-) { + next; + } + } if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { my $cmp2=$stored_what; - if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) }; + if (ref($stored_what) eq 'ARRAY') { + $cmp2=join('',@{$stored_what}); + } if ($cmp1 eq $cmp2) { push(@readonly_files, $file_name); + last; } elsif (!defined($what)) { push(@readonly_files, $file_name); + last; } } - } + } } return @readonly_files; } #-----------------------------------------------------------Get Marked as Read Only Hash sub get_marked_as_readonly_hash { - my ($domain,$user,$what) = @_; - my %current_permissions = &dump('file_permissions',$domain,$user); - my ($tmp)=keys(%current_permissions); - if ($tmp=~/^error:/) { undef(%current_permissions); } - + my ($current_permissions,$group,$what) = @_; my %readonly_files; - while (my ($file_name,$value) = each(%current_permissions)) { + while (my ($file_name,$value) = each(%{$current_permissions})) { + if (defined($group)) { + if ($file_name !~ m-^\Q$group\E/-) { + next; + } + } if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { - if ($stored_what eq $what) { - $readonly_files{$file_name} = 'locked'; - } elsif (!defined($what)) { - $readonly_files{$file_name} = 'locked'; - } + if (ref($stored_what) eq 'ARRAY') { + foreach my $lock_descriptor(@{$stored_what}) { + if ($lock_descriptor eq 'graded') { + $readonly_files{$file_name} = 'graded'; + } elsif ($lock_descriptor eq 'handback') { + $readonly_files{$file_name} = 'handback'; + } else { + if (!exists($readonly_files{$file_name})) { + $readonly_files{$file_name} = 'locked'; + } + } + } + } } } } @@ -4649,24 +5125,28 @@ sub get_marked_as_readonly_hash { sub unmark_as_readonly { # unmarks $file_name (if $file_name is defined), or all files locked by $what # for portfolio submissions, $what contains [$symb,$crsid] - my ($domain,$user,$what,$file_name) = @_; + my ($domain,$user,$what,$file_name,$group) = @_; + $file_name = &declutter_portfile($file_name); my $symb_crs = $what; if (ref($what)) { $symb_crs=join('',@$what); } - my %current_permissions = &dump('file_permissions',$domain,$user); + my %current_permissions = &dump('file_permissions',$domain,$user,$group); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } - my @readonly_files = &get_marked_as_readonly($domain,$user,$what); + my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group); foreach my $file (@readonly_files) { - if (defined($file_name) && ($file_name ne $file)) { next; } + my $clean_file = &declutter_portfile($file); + if (defined($file_name) && ($file_name ne $clean_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 ne $symb_crs) { - push(@new_locks, $locker); + if (ref($locker) eq 'ARRAY') { + $compare=join('',@{$locker}); + if ($compare ne $symb_crs) { + push(@new_locks, $locker); + } } } if (scalar(@new_locks) > 0) { @@ -4818,7 +5298,7 @@ sub stat_file { ($udom,$uname,$file) = ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-); $file = 'userfiles/'.$file; - $dir = &Apache::loncommon::propath($udom,$uname); + $dir = &propath($udom,$uname); } if ($uri =~ m-^/res/-) { ($udom,$uname) = @@ -4929,6 +5409,7 @@ sub devalidatecourseresdata { &devalidate_cache_new('courseres',$hashid); } + # --------------------------------------------------- Course Resourcedata Query sub get_courseresdata { @@ -5067,8 +5548,14 @@ sub EXT { if ( (defined($Apache::lonhomework::parsing_a_problem) || defined($Apache::lonhomework::parsing_a_task)) && - ($symbparm eq &symbread()) ) { - return $Apache::lonhomework::history{$qualifierrest}; + ($symbparm eq &symbread()) ) { + # if we are in the middle of processing the resource the + # get the value we are planning on committing + if (defined($Apache::lonhomework::results{$qualifierrest})) { + return $Apache::lonhomework::results{$qualifierrest}; + } else { + return $Apache::lonhomework::history{$qualifierrest}; + } } else { my %restored; if ($publicuser || $env{'request.state'} eq 'construct') { @@ -5275,6 +5762,9 @@ sub EXT { if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) { return $env{'environment.'.$spacequalifierrest}; } else { + if ($uname eq 'anonymous' && $udom eq '') { + return ''; + } my %returnhash=&userenvironment($udom,$uname, $spacequalifierrest); return $returnhash{$spacequalifierrest}; @@ -5425,7 +5915,7 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri !~ m -^(uploaded|editupload)/-) { + if ($uri !~ m -^(editupload)/-) { my $file=&filelocation('',&clutter($filename)); #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); @@ -5644,6 +6134,17 @@ sub metadata_generate_part0 { } } +# ------------------------------------------------------ Devalidate title cache + +sub devalidate_title_cache { + my ($url)=@_; + if (!$env{'request.course.id'}) { return; } + my $symb=&symbread($url); + if (!$symb) { return; } + my $key=$env{'request.course.id'}."\0".$symb; + &devalidate_cache_new('title',$key); +} + # ------------------------------------------------- Get the title of a resource sub gettitle { @@ -6454,7 +6955,7 @@ sub filelocation { my @ids=¤t_machine_ids(); foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } if ($is_me) { - $location=&Apache::loncommon::propath($udom,$uname). + $location=&propath($udom,$uname). '/userfiles/'.$filename; } else { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. @@ -6575,21 +7076,6 @@ sub freeze_escape { return &escape($value); } -# -------------------------------------------------------- Escape Special Chars - -sub escape { - my $str=shift; - $str =~ s/(\W)/"%".unpack('H2',$1)/eg; - return $str; -} - -# ----------------------------------------------------- Un-Escape Special Chars - -sub unescape { - my $str=shift; - $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - return $str; -} sub thaw_unescape { my ($value)=@_; @@ -6633,29 +7119,8 @@ BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { - # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block - open(my $config,") { - if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } - } - close($config); -} -{ - open(my $config,") { - if ($configline =~ /^[^\#]*PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } - } - close($config); + my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); + %perlvar = (%perlvar,%{$configvars}); } # ------------------------------------------------------------ Read domain file @@ -6737,7 +7202,9 @@ sub get_iphost { while (my $configline=<$config>) { chomp($configline); if ($configline) { - $spareid{$configline}=1; + my ($host,$type) = split(':',$configline,2); + if (!defined($type) || $type eq '') { $type = 'default' }; + push(@{ $spareid{$type} }, $host); } } close($config); @@ -6763,8 +7230,14 @@ sub get_iphost { while (my $configline=<$config>) { chomp($configline); if ($configline) { - my ($short,$plain)=split(/:/,$configline); - if ($plain ne '') { $prp{$short}=$plain; } + my ($short,@plain)=split(/:/,$configline); + %{$prp{$short}} = (); + if (@plain > 0) { + $prp{$short}{'std'} = $plain[0]; + for (my $i=1; $i<@plain; $i++) { + $prp{$short}{'alt'.$i} = $plain[$i]; + } + } } } close($config); @@ -7059,6 +7532,7 @@ actions '': forbidden 1: user needs to choose course 2: browse allowed + A: passphrase authentication needed =item * @@ -7458,6 +7932,31 @@ cput($namespace,$storehash,$udom,$uname) =item * +newput($namespace,$storehash,$udom,$uname) : + +Attempts to store the items in the $storehash, but only if they don't +currently exist, if this succeeds you can be certain that you have +successfully created a new key value pair in the $namespace db. + + +Args: + $namespace: name of database to store values to + $storehash: hashref to store to the db + $udom: (optional) domain of user containing the db + $uname: (optional) name of user caontaining the db + +Returns: + 'ok' -> succeeded in storing all keys of $storehash + 'key_exists: ' -> failed to anything out of $storehash, as at + least already existed in the db (other + requested keys may also already exist) + 'error: ' -> unable to tie the DB or other erorr occured + 'con_lost' -> unable to contact request server + 'refused' -> action was not allowed by remote machine + + +=item * + eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array reference filled in from namesp (encrypts the return communication) ($udom and $uname are optional) @@ -7692,6 +8191,94 @@ removeuploadedurl(): convience function Args: url: a full /uploaded/... url to delete +=item * + +get_portfile_permissions(): + Args: + domain: domain of user or course contain the portfolio files + user: name of user or num of course contain the portfolio files + Returns: + hashref of a dump of the proper file_permissions.db + + +=item * + +get_access_controls(): + +Args: + current_permissions: the hash ref returned from get_portfile_permissions() + group: (optional) the group you want the files associated with + file: (optional) the file you want access info on + +Returns: + a hash (keys are file names) of hashes containing + keys are: path to file/file_name\0uniqueID:scope_end_start (see below) + values are XML containing access control settings (see below) + +Internal notes: + + access controls are stored in file_permissions.db as key=value pairs. + key -> path to file/file_name\0uniqueID:scope_end_start + where scope -> public,guest,course,group,domains or users. + end -> UNIX time for end of access (0 -> no end date) + start -> UNIX time for start of access + + value -> XML description of access control + (type =1 of: public,guest,course,group,domains,users"> + + + + for scope type = guest + + for scope type = course or group + + + + +
+ + + + for scope type = domains + + for scope type = users + + + + + + + + Access data is also aggregated for each file in an additional key=value pair: + key -> path to file/file_name\0accesscontrol + value -> reference to hash + hash contains key = value pairs + where key = uniqueID:scope_end_start + value = UNIX time record was last updated + + Used to improve speed of look-ups of access controls for each file. + + Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. + +modify_access_controls(): + +Modifies access controls for a portfolio file +Args +1. file name +2. reference to hash of required changes, +3. domain +4. username + where domain,username are the domain of the portfolio owner + (either a user or a course) + +Returns: +1. result of additions or updates ('ok' or 'error', with error message). +2. result of deletions ('ok' or 'error', with error message). +3. reference to hash of any new or updated access controls. +4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. + key = integer (inbound ID) + value = uniqueID + =back =head2 HTTP Helper Routines