--- loncom/lonnet/perl/lonnet.pm 2005/11/01 15:07:29 1.674 +++ loncom/lonnet/perl/lonnet.pm 2005/12/22 20:56:28 1.687 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.674 2005/11/01 15:07:29 www Exp $ +# $Id: lonnet.pm,v 1.687 2005/12/22 20:56:28 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -40,8 +40,8 @@ qw(%perlvar %hostname %badServerCache %i %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 - %env); + %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary + $tmpdir $_64bit %env); use IO::Socket; use GDBM_File; @@ -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. @@ -1279,8 +1280,15 @@ sub clean_filename { } # --------------- Take an uploaded file and put it into the userfiles directory -# input: name of form element, coursedoc=1 means this is for the course -# output: url of file in userspace +# input: $formname - the contents of the file are in $env{"form.$formname"} +# the desired filenam is in $env{"form.$formname"} +# $coursedoc - if true up to the current course +# if false +# $subdir - directory in userfile to store the file into +# $parser, $allfiles, $codebase - unknown +# +# output: url of file in userspace, or error: +# or /adm/notfound.html if failure to upload occurse sub userfileupload { @@ -1852,28 +1860,25 @@ sub courseiddump { # ---------------------------------------------------------- DC e-mail sub dcmailput { - my ($domain,$msgid,$contents,$server)=@_; + my ($domain,$msgid,$message,$server)=@_; my $status = &Apache::lonnet::critical( 'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='. - &Apache::lonnet::escape($$contents{$server}),$server); + &Apache::lonnet::escape($message),$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); - } + my %returnhash=(); + if (exists($domain_primary{$dom})) { + my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. + &escape($enddate).':'; + my @esc_senders=map { &escape($_)} @$senders; + $cmd.=&escape(join('&',@esc_senders)); + foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { + my ($key,$value) = split(/\=/,$_); + if (($key) && ($value)) { + $returnhash{&unescape($key)} = &unescape($value); } } } @@ -2574,15 +2579,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 +2597,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 +2612,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 +2662,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 +2693,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 +3069,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 +3115,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 +3146,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 +3704,102 @@ 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); + if ($result eq 'ok') { + &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); + } + + 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 +3817,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 +3987,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 '. @@ -4638,7 +4792,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; @@ -4655,7 +4809,8 @@ sub EXT { return $env{'course.'.$courseid.'.'.$spacequalifierrest}; } elsif ($realm eq 'resource') { - my $section; + my ($section,$group); + my @groups = (); if (defined($courseid) && $courseid eq $env{'request.course.id'}) { if (!$symbparm) { $symbparm=&symbread(); } } @@ -4675,14 +4830,29 @@ sub EXT { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { $section=$env{'request.course.sec'}; + @groups=split(/:/,$env{'request.course.groups'}); + if (@groups > 0) { + @groups = sort(@groups); + $group = $groups[0]; + } } else { if (! defined($usection)) { $section=&getsection($udom,$uname,$courseid); } else { $section = $usection; } + my $grouplist = &get_users_groups($udom,$uname,$courseid); + if ($grouplist) { + @groups = split(/:/,$grouplist); + @groups = sort(@groups); + $group = $groups[0]; + } } + my $grplevel=$courseid.'.['.$group.'].'.$spacequalifierrest; + my $grplevelr=$courseid.'.['.$group.'].'.$symbparm; + my $grplevelm=$courseid.'.['.$group.'].'.$mapparm; + my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; @@ -4700,8 +4870,17 @@ sub EXT { if (defined($userreply)) { return $userreply; } # ------------------------------------------------ second, check some of course + my $coursereply; + if (defined($group)) { + $coursereply = &resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course', + ($grplevelr,$grplevelm,$grplevel, + $courselevelr)); + if (defined($coursereply)) { return $coursereply; } + } - my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, + $coursereply=&resdata($env{'course.'.$courseid.'.num'}, $env{'course.'.$courseid.'.domain'}, 'course', ($seclevelr,$seclevelm,$seclevel, @@ -5266,6 +5445,9 @@ sub symbread { if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { $targetfn = 'adm/wrapper/'.$thisfn; } + if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { + $targetfn=$1; + } if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', &GDBM_READER(),0640)) { $syval=$hash{$targetfn}; @@ -5379,8 +5561,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 { @@ -5420,11 +5631,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') { @@ -5547,6 +5762,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)=@_; { @@ -5585,6 +5806,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 =~/([,:])/) { @@ -5923,13 +6151,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; @@ -6000,7 +6221,7 @@ BEGIN { # next if /^\#/; chomp; my ($domain, $domain_description, $def_auth, $def_auth_arg, - $def_lang, $city, $longi, $lati) = split(/:/,$_); + $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_); $domain_auth_def{$domain}=$def_auth; $domain_auth_arg_def{$domain}=$def_auth_arg; $domaindescription{$domain}=$domain_description; @@ -6008,6 +6229,7 @@ BEGIN { $domain_city{$domain}=$city; $domain_longi{$domain}=$longi; $domain_lati{$domain}=$lati; + $domain_primary{$domain}=$primary; # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); # &logthis("Domain.tab: $domain ".$domaindescription{$domain} );