--- loncom/lonnet/perl/lonnet.pm 2005/10/31 19:32:19 1.673
+++ loncom/lonnet/perl/lonnet.pm 2005/11/22 00:01:53 1.683
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.673 2005/10/31 19:32:19 albertel Exp $
+# $Id: lonnet.pm,v 1.683 2005/11/22 00:01:53 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -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.
@@ -2574,15 +2575,17 @@ sub rolesinit {
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
my %allroles=();
+ my %allgroups=();
my $now=time;
my $userroles="user.login.time=$now\n";
+ my $group_privs;
if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;
- my ($trole,$tend,$tstart);
+ 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]+)_(.*)$|);
@@ -2590,6 +2593,10 @@ sub rolesinit {
} else {
$trole=$role;
}
+ } elsif ($role =~ m|^gr/|) {
+ ($trole,$tend,$tstart) = split(/_/,$role);
+ ($trole,$group_privs) = split(/\//,$trole);
+ $group_privs = &unescape($group_privs);
} else {
($trole,$tend,$tstart)=split(/_/,$role);
}
@@ -2601,13 +2608,15 @@ sub rolesinit {
my ($tdummy,$tdomain,$trest)=split(/\//,$area);
if ($trole =~ /^cr\//) {
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+ } elsif ($trole eq 'gr') {
+ &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
} else {
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}
}
}
}
- my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
+ my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);
$userroles.='user.adv='.$adv."\n".
'user.author='.$author."\n";
$env{'user.adv'}=$adv;
@@ -2649,6 +2658,17 @@ sub custom_roleprivs {
}
}
+sub group_roleprivs {
+ my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
+ my $access = 1;
+ my $now = time;
+ if (($tend!=0) && ($tend<$now)) { $access = 0; }
+ if (($tstart!=0) && ($tstart>$now)) { $access=0; }
+ if ($access) {
+ my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|);
+ $$allgroups{$course}{$group} .=':'.$group_privs;
+ }
+}
sub standard_roleprivs {
my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
@@ -2669,9 +2689,31 @@ sub standard_roleprivs {
}
sub set_userprivs {
- my ($userroles,$allroles) = @_;
+ my ($userroles,$allroles,$allgroups) = @_;
my $author=0;
my $adv=0;
+ my %grouproles = ();
+ if (keys(%{$allgroups}) > 0) {
+ foreach my $role (keys %{$allroles}) {
+ my ($trole,$area,$sec,$extendedarea);
+ if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {
+ $trole = $1;
+ $area = $2;
+ $sec = $3;
+ $extendedarea = $area.$sec;
+ if (exists($$allgroups{$area})) {
+ foreach my $group (keys(%{$$allgroups{$area}})) {
+ my $spec = $trole.'.'.$extendedarea;
+ $grouproles{$spec.'.'.$area.'/'.$group} =
+ $$allgroups{$area}{$group};
+ }
+ }
+ }
+ }
+ }
+ foreach (keys(%grouproles)) {
+ $$allroles{$_} = $grouproles{$_};
+ }
foreach (keys %{$allroles}) {
my %thesepriv=();
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
@@ -3023,8 +3065,6 @@ sub allowed {
my $orguri=$uri;
$uri=&declutter($uri);
-
-
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))
@@ -3071,7 +3111,7 @@ sub allowed {
if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
# uri is the requested domain in this case.
# comparison to 'request.role.domain' shows if the user has selected
- # a role of dc for the domain in question.
+ # a role of dc for the domain in question.
return 'F' if ($uri eq $env{'request.role.domain'});
}
@@ -3102,6 +3142,14 @@ 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/|)) {
@@ -3652,11 +3700,98 @@ sub auto_instcode_format {
return $response;
}
+# ------------------------------------------------------- Course Group routines
+
+sub get_coursegroups {
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('coursegroups',$cdom,$cnum,$group));
+}
+
+sub modify_coursegroup {
+ my ($cdom,$cnum,$groupsettings) = @_;
+ return(&put('coursegroups',$groupsettings,$cdom,$cnum));
+}
+
+sub modify_group_roles {
+ my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
+ my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
+ my $role = 'gr/'.&escape($userprivs);
+ my ($uname,$udom) = split(/:/,$user);
+ my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
+ return $result;
+}
+
+sub modify_coursegroup_membership {
+ my ($cdom,$cnum,$membership) = @_;
+ my $result = &put('groupmembership',$membership,$cdom,$cnum);
+ return $result;
+}
+
+sub get_active_groups {
+ my ($udom,$uname,$cdom,$cnum) = @_;
+ my $now = time;
+ my %groups = ();
+ foreach my $key (keys(%env)) {
+ if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {
+ my ($start,$end) = split(/\./,$env{$key});
+ if (($end!=0) && ($end<$now)) { next; }
+ if (($start!=0) && ($start>$now)) { next; }
+ if ($1 eq $cdom && $2 eq $cnum) {
+ $groups{$3} = $env{$key} ;
+ }
+ }
+ }
+ return %groups;
+}
+
+sub get_group_membership {
+ my ($cdom,$cnum,$group) = @_;
+ return(&dump('groupmembership',$cdom,$cnum,$group));
+}
+
+sub get_users_groups {
+ my ($udom,$uname,$courseid) = @_;
+ my $cachetime=1800;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+
+ my $hashid="$udom:$uname:$courseid";
+ my ($result,$cached)=&is_cached_new('getgroups',$hashid);
+ if (defined($cached)) { return $result; }
+
+ my %roleshash = &dump('roles',$udom,$uname,$courseid);
+ my ($tmp) = keys(%roleshash);
+ if ($tmp=~/^error:/) {
+ &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
+ return '';
+ } else {
+ my $grouplist;
+ foreach my $key (keys %roleshash) {
+ if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
+ unless ($roleshash{$key} =~ /_1_1$/) { # deleted membership
+ $grouplist .= $1.':';
+ }
+ }
+ }
+ $grouplist =~ s/:$//;
+ return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
+ }
+}
+
+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);
+}
+
# ------------------------------------------------------------------ Plain Text
sub plaintext {
my $short=shift;
- return &mt($prp{$short});
+ return &Apache::lonlocal::mt($prp{$short});
}
# ----------------------------------------------------------------- Assign Role
@@ -3674,6 +3809,16 @@ sub assignrole {
return 'refused';
}
$mrole='cr';
+ } elsif ($role =~ /^gr\//) {
+ my $cwogrp=$url;
+ $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+ unless (&allowed('mdg',$cwogrp)) {
+ &logthis('Refused group assignrole: '.
+ $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+ $env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
+ $mrole='gr';
} else {
my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
@@ -3834,6 +3979,7 @@ sub modifyuser {
}
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
+ &devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.
@@ -3974,7 +4120,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');
@@ -4636,7 +4784,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;
@@ -5377,8 +5525,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 {
@@ -5418,11 +5595,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') {
@@ -5545,6 +5726,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)=@_;
{
@@ -5583,6 +5770,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 =~/([,:])/) {
@@ -5921,13 +6115,6 @@ sub thaw_unescape {
return &unescape($value);
}
-sub mod_perl_version {
- return 1;
- if (defined($perlvar{'MODPERL2'})) {
- return 2;
- }
-}
-
sub correct_line_ends {
my ($result)=@_;
$$result =~s/\r\n/\n/mg;