--- loncom/lonnet/perl/lonnet.pm 2006/11/10 18:44:34 1.803
+++ loncom/lonnet/perl/lonnet.pm 2006/12/01 21:52:30 1.811
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.803 2006/11/10 18:44:34 albertel Exp $
+# $Id: lonnet.pm,v 1.811 2006/12/01 21:52:30 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -54,7 +54,7 @@ use Cache::Memcached;
use Digest::MD5;
use Math::Random;
use lib '/home/httpd/lib/perl';
-use LONCAPA;
+use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
my $readit;
@@ -588,8 +588,8 @@ sub queryauthenticate {
sub authenticate {
my ($uname,$upass,$udom)=@_;
- $upass=escape($upass);
- $uname=~s/\W//g;
+ $upass=&escape($upass);
+ $uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom);
if (!$uhome) {
&logthis("User $uname at $udom is unknown in authenticate");
@@ -694,6 +694,53 @@ sub idput {
}
}
+# ------------------------------------------- get items from domain db files
+
+sub get_dom {
+ my ($namespace,$storearr,$udom)=@_;
+ my $items='';
+ foreach my $item (@$storearr) {
+ $items.=&escape($item).'&';
+ }
+ $items=~s/\&$//;
+ if (!$udom) { $udom=$env{'user.domain'}; }
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ my @pairs=split(/\&/,$rep);
+ if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
+ return @pairs;
+ }
+ my %returnhash=();
+ my $i=0;
+ foreach my $item (@$storearr) {
+ $returnhash{$item}=&thaw_unescape($pairs[$i]);
+ $i++;
+ }
+ return %returnhash;
+ } else {
+ &logthis("get_dom failed - no primary domain server for $udom");
+ }
+}
+
+# -------------------------------------------- put items in domain db files
+
+sub put_dom {
+ my ($namespace,$storehash,$udom)=@_;
+ if (!$udom) { $udom=$env{'user.domain'}; }
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ my $items='';
+ foreach my $item (keys(%$storehash)) {
+ $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
+ }
+ $items=~s/\&$//;
+ return &reply("putdom:$udom:$namespace:$items",$uhome);
+ } else {
+ &logthis("put_dom failed - no primary domain server for $udom");
+ }
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -827,8 +874,6 @@ 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);
}
@@ -836,8 +881,6 @@ sub devalidate_getsection_cache {
sub getsection {
my ($udom,$unam,$courseid)=@_;
my $cachetime=1800;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$unam:$courseid";
my ($result,$cached)=&is_cached_new('getsection',$hashid);
@@ -1728,7 +1771,8 @@ sub flushcourselogs {
foreach my $entry (keys(%accesshash)) {
if ($entry =~ /___count$/) {
my ($dom,$name);
- ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
+ ($dom,$name,undef)=
+ ($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
if (! defined($dom) || $dom eq '' ||
! defined($name) || $name eq '') {
my $cid = $env{'request.course.id'};
@@ -1749,7 +1793,7 @@ sub flushcourselogs {
}
}
} else {
- my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
+ my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
my %temphash=($entry => $accesshash{$entry});
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
delete $accesshash{$entry};
@@ -2688,6 +2732,7 @@ sub coursedescription {
if (!$args->{'one_time'}) {
$envhash{'course.'.$normalid.'.last_cache'}=time;
}
+
if ($chome ne 'no_host') {
%returnhash=&dump('environment',$cdomain,$cnum);
if (!exists($returnhash{'con_lost'})) {
@@ -2763,8 +2808,8 @@ sub rolesinit {
$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart,$group_privs);
if ($role=~/^cr/) {
- if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) {
- ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|);
+ if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
+ ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
($tend,$tstart)=split('_',$trest);
} else {
$trole=$role;
@@ -2843,7 +2888,7 @@ sub group_roleprivs {
if (($tend!=0) && ($tend<$now)) { $access = 0; }
if (($tstart!=0) && ($tstart>$now)) { $access=0; }
if ($access) {
- my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);
+ my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
$$allgroups{$course}{$group} .=':'.$group_privs;
}
}
@@ -2874,7 +2919,7 @@ sub set_userprivs {
if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);
- if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) {
+ if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
$trole = $1;
$area = $2;
$sec = $3;
@@ -3332,7 +3377,7 @@ sub get_portfolio_access {
my (%allgroups,%allroles);
my ($start,$end,$role,$sec,$group);
foreach my $envkey (%env) {
- if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) {
+ if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;
if ($1 eq 'gr') {
$group = $4;
@@ -3345,7 +3390,7 @@ sub get_portfolio_access {
}
$allroles{$cid}{$1}{$sec} = $env{$envkey};
}
- } elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) {
+ } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;
if ($4 eq '') {
$sec = 'none';
@@ -3440,12 +3485,12 @@ sub parse_portfolio_url {
my ($type,$udom,$unum,$group,$file_name);
- if ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) {
+ if ($url =~ m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) {
$type = 1;
$udom = $1;
$unum = $2;
$file_name = $3;
- } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) {
+ } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
$type = 2;
$udom = $1;
$unum = $2;
@@ -3465,7 +3510,7 @@ sub is_portfolio_url {
sub is_portfolio_file {
my ($file) = @_;
- if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
+ if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w\/portfolio/)) {
return 1;
}
return;
@@ -3476,9 +3521,10 @@ sub is_portfolio_file {
sub customaccess {
my ($priv,$uri)=@_;
- my ($urole,$urealm)=split(/\./,$env{'request.role'});
- $urealm=~s/^\W//;
+ my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
my ($udom,$ucrs,$usec)=split(/\//,$urealm);
+ $udom = &LONCAPA::clean_domain($udom);
+ $ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;
foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
my ($effect,$realm,$role)=split(/\:/,$right);
@@ -3509,12 +3555,21 @@ sub customaccess {
# ------------------------------------------------- Check for a user privilege
sub allowed {
- my ($priv,$uri,$symb)=@_;
+ my ($priv,$uri,$symb,$role)=@_;
my $ver_orguri=$uri;
$uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
-
+
+ if ($priv eq 'evb') {
+# Evade communication block restrictions for specified role in a course
+ if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
+ return $1;
+ } else {
+ return;
+ }
+ }
+
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
@@ -4299,8 +4354,8 @@ sub auto_instcode_defaults {
$returnhash->{&unescape($name)}=&unescape($value);
}
}
+ $ok_response = 1;
}
- $ok_response = 1;
}
if ($ok_response) {
return 'ok';
@@ -4320,8 +4375,8 @@ sub auto_validate_class_sec {
# ------------------------------------------------------- Course Group routines
sub get_coursegroups {
- my ($cdom,$cnum,$group) = @_;
- return(&dump('coursegroups',$cdom,$cnum,$group));
+ my ($cdom,$cnum,$group,$namespace) = @_;
+ return(&dump($namespace,$cdom,$cnum,$group));
}
sub modify_coursegroup {
@@ -4329,6 +4384,37 @@ sub modify_coursegroup {
return(&put('coursegroups',$groupsettings,$cdom,$cnum));
}
+sub toggle_coursegroup_status {
+ my ($cdom,$cnum,$group,$action) = @_;
+ my ($from_namespace,$to_namespace);
+ if ($action eq 'delete') {
+ $from_namespace = 'coursegroups';
+ $to_namespace = 'deleted_groups';
+ } else {
+ $from_namespace = 'deleted_groups';
+ $to_namespace = 'coursegroups';
+ }
+ my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
+ if (my $tmp = &error(%curr_group)) {
+ &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
+ return ('read error',$tmp);
+ } else {
+ my %savedsettings = %curr_group;
+ my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum);
+ my $deloutcome;
+ if ($result eq 'ok') {
+ $deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
+ } else {
+ return ('write error',$result);
+ }
+ if ($deloutcome eq 'ok') {
+ return 'ok';
+ } else {
+ return ('delete error',$deloutcome);
+ }
+ }
+}
+
sub modify_group_roles {
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
@@ -4352,7 +4438,7 @@ sub get_active_groups {
my $now = time;
my %groups = ();
foreach my $key (keys(%env)) {
- if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
+ if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
my ($start,$end) = split(/\./,$env{$key});
if (($end!=0) && ($end<$now)) { next; }
if (($start!=0) && ($start>$now)) { next; }
@@ -4373,8 +4459,6 @@ sub get_users_groups {
my ($udom,$uname,$courseid) = @_;
my @usersgroups;
my $cachetime=1800;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$uname:$courseid";
my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
@@ -4421,8 +4505,7 @@ sub get_users_groups {
sub devalidate_getgroups_cache {
my ($udom,$uname,$cdom,$cnum)=@_;
my $courseid = $cdom.'_'.$cnum;
- $courseid=~s/\_/\//g;
- $courseid=~s/^(\w)/\/$1/;
+
my $hashid="$udom:$uname:$courseid";
&devalidate_cache_new('getgroups',$hashid);
}
@@ -4461,7 +4544,7 @@ sub assignrole {
my $mrole;
if ($role =~ /^cr\//) {
my $cwosec=$url;
- $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {
&logthis('Refused custom assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -4471,7 +4554,7 @@ sub assignrole {
$mrole='cr';
} elsif ($role =~ /^gr\//) {
my $cwogrp=$url;
- $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
unless (&allowed('mdg',$cwogrp)) {
&logthis('Refused group assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -4481,7 +4564,7 @@ sub assignrole {
$mrole='gr';
} else {
my $cwosec=$url;
- $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {
&logthis('Refused assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
@@ -4561,8 +4644,8 @@ sub modifyuser {
$umode, $upass, $first,
$middle, $last, $gene,
$forceid, $desiredhome, $email)=@_;
- $udom=~s/\W//g;
- $uname=~s/\W//g;
+ $udom= &LONCAPA::clean_domain($udom);
+ $uname=&LONCAPA::clean_username($uname);
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.'(forceid: '.$forceid.')'.
@@ -5336,8 +5419,8 @@ sub dirlist {
##
sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;
- $studentDomain=~s/\W//g;
- $studentName=~s/\W//g;
+ $studentDomain = &LONCAPA::clean_domain($studentDomain);
+ $studentName = &LONCAPA::clean_username($studentName);
my $subdir=$studentName.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$studentDomain/$subdir/$studentName";
@@ -5360,13 +5443,13 @@ sub stat_file {
my ($udom,$uname,$file,$dir);
if ($uri =~ m-^/(uploaded|editupload)/-) {
($udom,$uname,$file) =
- ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-);
+ ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
$file = 'userfiles/'.$file;
$dir = &propath($udom,$uname);
}
if ($uri =~ m-^/res/-) {
($udom,$uname) =
- ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-);
+ ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
$file = $uri;
}
@@ -5947,7 +6030,7 @@ sub metadata {
(($uri =~ m|^/*adm/|) &&
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
- ($uri =~ m|home/[^/]+/public_html/|)) {
+ ($uri =~ m|home/$match_username/public_html/|)) {
return undef;
}
my $filename=$uri;
@@ -6925,7 +7008,7 @@ sub repcopy_userfile {
if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
my ($cdom,$cnum,$filename) =
- ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
+ ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
my ($info,$rtncode);
my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {
@@ -7042,12 +7125,12 @@ 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/:) {
+ } elsif ($file=~m{^/home/$match_username/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)/+([^/]+)/+([^/]+)/+(.*)$-);
+ ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
my $home=&homeserver($uname,$udom);
my $is_me=0;
my @ids=¤t_machine_ids();
@@ -7084,10 +7167,10 @@ sub hreflocation {
}
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/-;
+ } elsif ($file=~m-/home/($match_username)/public_html/-) {
+ $file=~s-^/home/($match_username)/public_html/-/~$1/-;
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
- $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/
+ $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;
}
return $file;
@@ -7641,8 +7724,7 @@ passed in @what from the requested user'
=item *
-allowed($priv,$uri) : check for a user privilege; returns codes for allowed
-actions
+allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
F: full access
U,I,K: authentication modes (cxx only)
'': forbidden
@@ -8082,6 +8164,15 @@ reference filled in from namesp (encrypt
log($udom,$name,$home,$message) : write to permanent log for user; use
critical subroutine
+=item *
+
+get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
+reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
+
+=item *
+
+put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional)
+
=back
=head2 Network Status Functions