--- loncom/lonnet/perl/lonnet.pm 2009/11/29 00:17:22 1.1046
+++ loncom/lonnet/perl/lonnet.pm 2010/07/17 20:02:13 1.1073
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1046 2009/11/29 00:17:22 raeburn Exp $
+# $Id: lonnet.pm,v 1.1073 2010/07/17 20:02:13 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -76,7 +76,7 @@ use HTTP::Date;
use Image::Magick;
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
- $_64bit %env %protocol);
+ $_64bit %env %protocol %loncaparevs);
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,
@@ -99,8 +99,6 @@ use LONCAPA::Configuration;
my $readit;
my $max_connection_retries = 10; # Or some such value.
-my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true
-
require Exporter;
our @ISA = qw (Exporter);
@@ -198,7 +196,7 @@ sub get_server_timezone {
}
sub get_server_loncaparev {
- my ($dom,$lonhost) = @_;
+ my ($dom,$lonhost,$ignore_cache,$caller) = @_;
if (defined($lonhost)) {
if (!defined(&hostname($lonhost))) {
undef($lonhost);
@@ -213,14 +211,45 @@ sub get_server_loncaparev {
}
}
if (defined($lonhost)) {
- my $cachetime = 24*3600;
- my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
- if (defined($cached)) {
- return $loncaparev;
- } else {
- my $loncaparev = &reply('serverloncaparev',$lonhost);
- return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
+ my $cachetime = 12*3600;
+ if (!$ignore_cache) {
+ my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
+ if (defined($cached)) {
+ return $loncaparev;
+ }
+ }
+ my ($answer,$loncaparev);
+ my @ids=¤t_machine_ids();
+ if (grep(/^\Q$lonhost\E$/,@ids)) {
+ $answer = $perlvar{'lonVersion'};
+ if ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) {
+ $loncaparev = $1;
+ }
+ } else {
+ $answer = &reply('serverloncaparev',$lonhost);
+ if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
+ if ($caller eq 'loncron') {
+ my $ua=new LWP::UserAgent;
+ $ua->timeout(20);
+ my $protocol = $protocol{$lonhost};
+ $protocol = 'http' if ($protocol ne 'https');
+ my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';
+ my $request=new HTTP::Request('GET',$url);
+ my $response=$ua->request($request);
+ unless ($response->is_error()) {
+ my $content = $response->content;
+ if ($content =~ /<p>VERSION\:\s*([\d.\-]+)<\/p>/) {
+ $loncaparev = $1;
+ }
+ }
+ } else {
+ $loncaparev = $loncaparevs{$lonhost};
+ }
+ } elsif ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) {
+ $loncaparev = $1;
+ }
}
+ return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
}
}
@@ -667,30 +696,6 @@ sub userload {
return $userloadpercent;
}
-# ------------------------------------------ Fight off request when overloaded
-
-sub overloaderror {
- my ($r,$checkserver)=@_;
- unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
- my $loadavg;
- if ($checkserver eq $perlvar{'lonHostID'}) {
- open(my $loadfile,'/proc/loadavg');
- $loadavg=<$loadfile>;
- $loadavg =~ s/\s.*//g;
- $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
- close($loadfile);
- } else {
- $loadavg=&reply('load',$checkserver);
- }
- my $overload=$loadavg-100;
- if ($overload>0) {
- $r->err_headers_out->{'Retry-After'}=$overload;
- $r->log_error('Overload of '.$overload.' on '.$checkserver);
- return 413;
- }
- return '';
-}
-
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
@@ -736,7 +741,7 @@ sub compare_server_load {
my $userloadans = &reply('userload',$try_server);
if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
- next; #didn't get a number from the server
+ return; #didn't get a number from the server
}
my $load;
@@ -837,7 +842,7 @@ sub queryauthenticate {
# --------- Try to authenticate user from domain's lib servers (first this one)
sub authenticate {
- my ($uname,$upass,$udom,$checkdefauth)=@_;
+ my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_;
$upass=&escape($upass);
$uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom,1);
@@ -860,7 +865,7 @@ sub authenticate {
return 'no_host';
}
}
- my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);
+ my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome);
if ($answer eq 'authorized') {
if ($newhome) {
&logthis("User $uname at $udom authorized by $uhome, but needs account");
@@ -878,6 +883,63 @@ sub authenticate {
return 'no_host';
}
+sub can_host_session {
+ my ($udom,$machinedom,$remoterev,$remotesessions,$hostedsessions) = @_;
+ my $canhost = 1;
+ if (ref($remotesessions) eq 'HASH') {
+ if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
+ if (grep(/^\Q$machinedom\E$/,@{$remotesessions->{'excludedomain'}})) {
+ $canhost = 0;
+ } else {
+ $canhost = 1;
+ }
+ }
+ if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') {
+ if (grep(/^\Q$machinedom\E$/,@{$remotesessions->{'includedomain'}})) {
+ $canhost = 1;
+ } else {
+ $canhost = 0;
+ }
+ }
+ if ($canhost) {
+ if ($remotesessions->{'version'} ne '') {
+ my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/);
+ if ($reqmajor ne '' && $reqminor ne '') {
+ if ($remoterev =~ /^\'?(\d+)\.(\d+)/) {
+ my $major = $1;
+ my $minor = $2;
+ if (($major < $reqmajor ) ||
+ (($major == $reqmajor) && ($minor < $reqminor))) {
+ $canhost = 0;
+ }
+ } else {
+ $canhost = 0;
+ }
+ }
+ }
+ }
+ }
+ if ($canhost) {
+ if (ref($hostedsessions) eq 'HASH') {
+ if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
+ if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {
+ $canhost = 0;
+ } else {
+ $canhost = 1;
+ }
+ }
+ if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
+ if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {
+ $canhost = 1;
+ } else {
+ $canhost = 0;
+ }
+ }
+ }
+ }
+ return $canhost;
+}
+
# ---------------------- Find the homebase for a user from domain's lib servers
my %homecache;
@@ -1353,7 +1415,8 @@ sub get_domain_defaults {
my %domdefaults;
my %domconfig =
&Apache::lonnet::get_dom('configuration',['defaults','quotas',
- 'requestcourses','inststatus'],$domain);
+ 'requestcourses','inststatus',
+ 'coursedefaults','usersessions'],$domain);
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
@@ -1388,6 +1451,19 @@ sub get_domain_defaults {
$domdefaults{$item} = $domconfig{'inststatus'}{$item};
}
}
+ if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
+ foreach my $item ('canuse_pdfforms') {
+ $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
+ }
+ }
+ if (ref($domconfig{'usersessions'}) eq 'HASH') {
+ if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
+ $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'};
+ }
+ if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
+ $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
+ }
+ }
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
$cachetime);
return %domdefaults;
@@ -1722,6 +1798,9 @@ sub userenvironment {
unless ($uhome eq 'no_host') {
my @answer=split(/\&/,
&reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
+ if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) {
+ return %returnhash;
+ }
my $i;
for ($i=0;$i<=$#what;$i++) {
$returnhash{$what[$i]}=&unescape($answer[$i]);
@@ -2147,31 +2226,42 @@ sub clean_filename {
$fname=~s/\.(\d+)(?=\.)/_$1/g;
return $fname;
}
-#This Function check if a Image max 400px width and height 500px. If not then scale the image down
+# This Function checks if an Image's dimensions exceed either $resizewidth (width)
+# or $resizeheight (height) - both pixels. If so, the image is scaled to produce an
+# image with the same aspect ratio as the original, but with dimensions which do
+# not exceed $resizewidth and $resizeheight.
+
sub resizeImage {
- my($img_url) = @_;
- my $ima = Image::Magick->new;
- $ima->Read($img_url);
- if($ima->Get('width') > 400)
- {
- my $factor = $ima->Get('width')/400;
- $ima->Scale( width=>400, height=>$ima->Get('height')/$factor );
- }
- if($ima->Get('height') > 500)
- {
- my $factor = $ima->Get('height')/500;
- $ima->Scale( width=>$ima->Get('width')/$factor, height=>500);
- }
-
- $ima->Write($img_url);
-}
-
-#Wrapper function for userphotoupload
-sub userphotoupload
-{
- my($formname,$subdir) = @_;
- $upload_photo_form = 1;
- return &userfileupload($formname,undef,$subdir);
+ my ($img_path,$resizewidth,$resizeheight) = @_;
+ my $ima = Image::Magick->new;
+ my $resized;
+ if (-e $img_path) {
+ $ima->Read($img_path);
+ if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) {
+ my $width = $ima->Get('width');
+ my $height = $ima->Get('height');
+ if ($width > $resizewidth) {
+ my $factor = $width/$resizewidth;
+ my $newheight = $height/$factor;
+ $ima->Scale(width=>$resizewidth,height=>$newheight);
+ $resized = 1;
+ }
+ }
+ if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) {
+ my $width = $ima->Get('width');
+ my $height = $ima->Get('height');
+ if ($height > $resizeheight) {
+ my $factor = $height/$resizeheight;
+ my $newwidth = $width/$factor;
+ $ima->Scale(width=>$newwidth,height=>$resizeheight);
+ $resized = 1;
+ }
+ }
+ if ($resized) {
+ $ima->Write($img_path);
+ }
+ }
+ return;
}
# --------------- Take an uploaded file and put it into the userfiles directory
@@ -2187,14 +2277,15 @@ sub userphotoupload
# $dsetudom - domain for permanaent storage of uploaded file
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image
# $thumbheight - height (pixels) of thumbnail to make for uploaded image
+# $resizewidth - width (pixels) to which to resize uploaded image
+# $resizeheight - height (pixels) to which to resize uploaded image
#
# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse
-
sub userfileupload {
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
- $destudom,$thumbwidth,$thumbheight)=@_;
+ $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_;
if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);
@@ -2244,7 +2335,8 @@ sub userfileupload {
if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
return &finishuserfileupload($docuname,$docudom,
$formname,$fname,$parser,$allfiles,
- $codebase,$thumbwidth,$thumbheight);
+ $codebase,$thumbwidth,$thumbheight,
+ $resizewidth,$resizeheight);
} else {
$fname=$env{'form.folder'}.'/'.$fname;
return &process_coursefile('uploaddoc',$docuname,$docudom,
@@ -2256,7 +2348,8 @@ sub userfileupload {
my $docudom=$destudom;
return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$parser,$allfiles,$codebase,
- $thumbwidth,$thumbheight);
+ $thumbwidth,$thumbheight,
+ $resizewidth,$resizeheight);
} else {
my $docuname=$env{'user.name'};
@@ -2267,13 +2360,14 @@ sub userfileupload {
}
return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$parser,$allfiles,$codebase,
- $thumbwidth,$thumbheight);
+ $thumbwidth,$thumbheight,
+ $resizewidth,$resizeheight);
}
}
sub finishuserfileupload {
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
- $thumbwidth,$thumbheight) = @_;
+ $thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
@@ -2305,10 +2399,12 @@ sub finishuserfileupload {
return '/adm/notfound.html';
}
close(FH);
- if($upload_photo_form==1)
- {
- resizeImage($filepath.'/'.$file);
- $upload_photo_form = 0;
+ if ($resizewidth && $resizeheight) {
+ my $mm = new File::MMagic;
+ my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
+ if ($mime_type =~ m{^image/}) {
+ &resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight);
+ }
}
}
if ($parser eq 'parse') {
@@ -2995,6 +3091,7 @@ sub getannounce {
sub courseidput {
my ($domain,$storehash,$coursehome,$caller) = @_;
+ return unless (ref($storehash) eq 'HASH');
my $outcome;
if ($caller eq 'timeonly') {
my $cids = '';
@@ -3034,7 +3131,7 @@ sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
- $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
+ $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -3056,7 +3153,8 @@ sub courseiddump {
$showhidden.':'.$caller.':'.&escape($cloner).':'.
&escape($cc_clone).':'.$cloneonly.':'.
&escape($createdbefore).':'.&escape($createdafter).':'.
- &escape($creationcontext),$tryserver);
+ &escape($creationcontext).':'.$domcloner,
+ $tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3079,6 +3177,49 @@ sub courseiddump {
return %returnhash;
}
+sub courselastaccess {
+ my ($cdom,$cnum,$hostidref) = @_;
+ my %returnhash;
+ if ($cdom && $cnum) {
+ my $chome = &homeserver($cnum,$cdom);
+ if ($chome ne 'no_host') {
+ my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome);
+ &extract_lastaccess(\%returnhash,$rep);
+ }
+ } else {
+ if (!$cdom) { $cdom=''; }
+ my %libserv = &all_library();
+ foreach my $tryserver (keys(%libserv)) {
+ if (ref($hostidref) eq 'ARRAY') {
+ next unless (grep(/^\Q$tryserver\E$/,@{$hostidref}));
+ }
+ if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) {
+ my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver);
+ &extract_lastaccess(\%returnhash,$rep);
+ }
+ }
+ }
+ return %returnhash;
+}
+
+sub extract_lastaccess {
+ my ($returnhash,$rep) = @_;
+ if (ref($returnhash) eq 'HASH') {
+ unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+ $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
+ $rep eq '') {
+ my @pairs=split(/\&/,$rep);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/\=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash->{$key} = &thaw_unescape($value);
+ }
+ }
+ }
+ return;
+}
+
# ---------------------------------------------------------- DC e-mail
sub dcmailput {
@@ -3139,7 +3280,7 @@ sub get_domain_roles {
return %personnel;
}
-# ----------------------------------------------------------- Check out an item
+# ----------------------------------------------------------- Interval timing
sub get_first_access {
my ($type,$argsymb)=@_;
@@ -3175,91 +3316,6 @@ sub set_first_access {
return 'already_set';
}
-sub checkout {
- my ($symb,$tuname,$tudom,$tcrsid)=@_;
- my $now=time;
- my $lonhost=$perlvar{'lonHostID'};
- my $infostr=&escape(
- 'CHECKOUTTOKEN&'.
- $tuname.'&'.
- $tudom.'&'.
- $tcrsid.'&'.
- $symb.'&'.
- $now.'&'.$ENV{'REMOTE_ADDR'});
- my $token=&reply('tmpput:'.$infostr,$lonhost);
- if ($token=~/^error\:/) {
- &logthis("<font color=\"blue\">WARNING: ".
- "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
- "</font>");
- return '';
- }
-
- $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
- $token=~tr/a-z/A-Z/;
-
- my %infohash=('resource.0.outtoken' => $token,
- 'resource.0.checkouttime' => $now,
- 'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
-
- unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
- return '';
- } else {
- &logthis("<font color=\"blue\">WARNING: ".
- "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
- "</font>");
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkout '.$infostr.' - '.
- $token)) ne 'ok') {
- return '';
- } else {
- &logthis("<font color=\"blue\">WARNING: ".
- "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
- "</font>");
- }
- return $token;
-}
-
-# ------------------------------------------------------------ Check in an item
-
-sub checkin {
- my $token=shift;
- my $now=time;
- my ($ta,$tb,$lonhost)=split(/\*/,$token);
- $lonhost=~tr/A-Z/a-z/;
- my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
- $dtoken=~s/\W/\_/g;
- my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
- split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
-
- unless (($tuname) && ($tudom)) {
- &logthis('Check in '.$token.' ('.$dtoken.') failed');
- return '';
- }
-
- unless (&allowed('mgr',$tcrsid)) {
- &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
- $env{'user.name'}.' - '.$env{'user.domain'});
- return '';
- }
-
- my %infohash=('resource.0.intoken' => $token,
- 'resource.0.checkintime' => $now,
- 'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
-
- unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
- return '';
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkin - '.$token)) ne 'ok') {
- return '';
- }
-
- return ($symb,$tuname,$tudom,$tcrsid);
-}
-
# --------------------------------------------- Set Expire Date for Spreadsheet
sub expirespread {
@@ -3960,23 +4016,36 @@ sub standard_roleprivs {
}
sub set_userprivs {
- my ($userroles,$allroles,$allgroups) = @_;
+ my ($userroles,$allroles,$allgroups,$groups_roles) = @_;
my $author=0;
my $adv=0;
my %grouproles = ();
if (keys(%{$allgroups}) > 0) {
+ my @groupkeys;
foreach my $role (keys(%{$allroles})) {
- my ($trole,$area,$sec,$extendedarea);
- if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\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} =
+ push(@groupkeys,$role);
+ }
+ if (ref($groups_roles) eq 'HASH') {
+ foreach my $key (keys(%{$groups_roles})) {
+ unless (grep(/^\Q$key\E$/,@groupkeys)) {
+ push(@groupkeys,$key);
+ }
+ }
+ }
+ if (@groupkeys > 0) {
+ foreach my $role (@groupkeys) {
+ my ($trole,$area,$sec,$extendedarea);
+ if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\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};
+ }
}
}
}
@@ -4023,33 +4092,58 @@ sub role_status {
if ($$tstart<$now) {
if ($$tstart && $$tstart>$refresh) {
if (($$where ne '') && ($$role ne '')) {
- my (%allroles,%allgroups,$group_privs);
+ my (%allroles,%allgroups,$group_privs,
+ %groups_roles,@rolecodes);
my %userroles = (
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
);
+ @rolecodes = ('cm');
my $spec=$$role.'.'.$$where;
my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
- if ($$role eq 'gr') {
- my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
- $env{'user.name'})=@_;
- my ($trole) = split('_',$role,1);
- (undef,my $group_privs) = split(/\//,$trole);
- $group_privs = &unescape($group_privs);
- }
if ($$role =~ /^cr\//) {
&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
+ push(@rolecodes,'cr');
} elsif ($$role eq 'gr') {
+ push(@rolecodes,$$role);
my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
$env{'user.name'});
- my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
+ my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2);
(undef,my $group_privs) = split(/\//,$trole);
$group_privs = &unescape($group_privs);
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
+ my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
+ if (keys(%course_roles) > 0) {
+ my ($tnum) = ($trest =~ /^($match_courseid)/);
+ if ($tdomain ne '' && $tnum ne '') {
+ foreach my $key (keys(%course_roles)) {
+ if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {
+ my $crsrole = $1;
+ my $crssec = $2;
+ if ($crsrole =~ /^cr/) {
+ unless (grep(/^cr$/,@rolecodes)) {
+ push(@rolecodes,'cr');
+ }
+ } else {
+ unless(grep(/^\Q$crsrole\E$/,@rolecodes)) {
+ push(@rolecodes,$crsrole);
+ }
+ }
+ my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum;
+ if ($crssec ne '') {
+ $rolekey .= '/'.$crssec;
+ }
+ $rolekey .= './';
+ $groups_roles{$rolekey} = \@rolecodes;
+ }
+ }
+ }
+ }
} else {
+ push(@rolecodes,$$role);
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
}
- my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
- &appenv(\%userroles,[$$role,'cm']);
+ my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);
+ &appenv(\%userroles,\@rolecodes);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
}
}
@@ -4563,7 +4657,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)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
+ if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;
if ($1 eq 'gr') {
$group = $4;
@@ -4811,6 +4905,27 @@ sub usertools_access {
}
}
+sub is_course_owner {
+ my ($cdom,$cnum,$udom,$uname) = @_;
+ if (($udom eq '') || ($uname eq '')) {
+ $udom = $env{'user.domain'};
+ $uname = $env{'user.name'};
+ }
+ unless (($udom eq '') || ($uname eq '')) {
+ if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) {
+ if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
+ return 1;
+ } else {
+ my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);
+ if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
+ return 1;
+ }
+ }
+ }
+ }
+ return;
+}
+
sub is_advanced_user {
my ($udom,$uname) = @_;
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
@@ -5730,8 +5845,8 @@ sub auto_validate_instcode {
$homeserver = &domain($cdom,'primary');
}
}
- my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
- &escape($instcode).':'.&escape($owner),$homeserver));
+ $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
+ &escape($instcode).':'.&escape($owner),$homeserver));
my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
return ($outcome,$description);
}
@@ -6319,10 +6434,97 @@ sub assignrole {
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
$origstart,$selfenroll,$context);
}
+ if ($role eq 'cc') {
+ &autoupdate_coowners($url,$end,$start,$uname,$udom);
+ }
}
return $answer;
}
+sub autoupdate_coowners {
+ my ($url,$end,$start,$uname,$udom) = @_;
+ my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)});
+ if (($cdom ne '') && ($cnum ne '')) {
+ my $now = time;
+ my %domdesign = &Apache::loncommon::get_domainconf($cdom);
+ if ($domdesign{$cdom.'.autoassign.co-owners'}) {
+ my %coursehash = &coursedescription($cdom.'_'.$cnum);
+ my $instcode = $coursehash{'internal.coursecode'};
+ if ($instcode ne '') {
+ if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
+ unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
+ my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
+ my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
+ if ($result eq 'valid') {
+ if ($coursehash{'internal.co-owners'}) {
+ foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+ push(@newcoowners,$coowner);
+ }
+ unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) {
+ push(@newcoowners,$uname.':'.$udom);
+ }
+ @newcoowners = sort(@newcoowners);
+ } else {
+ push(@newcoowners,$uname.':'.$udom);
+ }
+ } else {
+ if ($coursehash{'internal.co-owners'}) {
+ foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+ unless ($coowner eq $uname.':'.$udom) {
+ push(@newcoowners,$coowner);
+ }
+ }
+ unless (@newcoowners > 0) {
+ $delcoowners = 1;
+ $coowners = '';
+ }
+ }
+ }
+ if (@newcoowners || $delcoowners) {
+ &store_coowners($cdom,$cnum,$coursehash{'home'},
+ $delcoowners,@newcoowners);
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+sub store_coowners {
+ my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_;
+ my $cid = $cdom.'_'.$cnum;
+ my ($coowners,$delresult,$putresult);
+ if (@newcoowners) {
+ $coowners = join(',',@newcoowners);
+ my %coownershash = (
+ 'internal.co-owners' => $coowners,
+ );
+ $putresult = &put('environment',\%coownershash,$cdom,$cnum);
+ if ($putresult eq 'ok') {
+ if ($env{'course.'.$cid.'.num'} eq $cnum) {
+ &appenv({'course.'.$cid.'.internal.co-owners' => $coowners});
+ }
+ }
+ }
+ if ($delcoowners) {
+ $delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum);
+ if ($delresult eq 'ok') {
+ if ($env{'course.'.$cid.'.internal.co-owners'}) {
+ &Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners');
+ }
+ }
+ }
+ if (($putresult eq 'ok') || ($delresult eq 'ok')) {
+ my %crsinfo =
+ &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
+ if (ref($crsinfo{$cid}) eq 'HASH') {
+ $crsinfo{$cid}{'co-owners'} = \@newcoowners;
+ my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');
+ }
+ }
+}
+
# -------------------------------------------------- Modify user authentication
# Overrides without validation
@@ -6355,12 +6557,18 @@ sub modifyuser {
my ($udom, $uname, $uid,
$umode, $upass, $first,
$middle, $last, $gene,
- $forceid, $desiredhome, $email, $inststatus)=@_;
+ $forceid, $desiredhome, $email, $inststatus, $candelete)=@_;
$udom= &LONCAPA::clean_domain($udom);
$uname=&LONCAPA::clean_username($uname);
+ my $showcandelete = 'none';
+ if (ref($candelete) eq 'ARRAY') {
+ if (@{$candelete} > 0) {
+ $showcandelete = join(', ',@{$candelete});
+ }
+ }
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.'(forceid: '.$forceid.')'.
+ $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
(defined($desiredhome) ? ' desiredhome = '.$desiredhome :
' desiredhome not specified').
' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
@@ -6425,9 +6633,33 @@ sub modifyuser {
%names = @tmp;
}
#
-# Make sure to not trash student environment if instructor does not bother
-# to supply name and email information
-#
+# If name, email and/or uid are blank (e.g., because an uploaded file
+# of users did not contain them), do not overwrite existing values
+# unless field is in $candelete array ref.
+#
+
+ my @fields = ('firstname','middlename','lastname','generation',
+ 'permanentemail','id');
+ my %newvalues;
+ if (ref($candelete) eq 'ARRAY') {
+ foreach my $field (@fields) {
+ if (grep(/^\Q$field\E$/,@{$candelete})) {
+ if ($field eq 'firstname') {
+ $names{$field} = $first;
+ } elsif ($field eq 'middlename') {
+ $names{$field} = $middle;
+ } elsif ($field eq 'lastname') {
+ $names{$field} = $last;
+ } elsif ($field eq 'generation') {
+ $names{$field} = $gene;
+ } elsif ($field eq 'permanentemail') {
+ $names{$field} = $email;
+ } elsif ($field eq 'id') {
+ $names{$field} = $uid;
+ }
+ }
+ }
+ }
if ($first) { $names{'firstname'} = $first; }
if (defined($middle)) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }
@@ -6647,9 +6879,17 @@ sub createcourse {
}
return $uname if ($uname =~ /^error/);
# -------------------------------------------------- Check supplied server name
- $course_server = $env{'user.homeserver'} if (! defined($course_server));
- if (! &is_library($course_server)) {
- return 'error:bad server name '.$course_server;
+ if (!defined($course_server)) {
+ if (defined(&domain($udom,'primary'))) {
+ $course_server = &domain($udom,'primary');
+ } else {
+ $course_server = $env{'user.home'};
+ }
+ }
+ my %host_servers =
+ &Apache::lonnet::get_servers($udom,'library');
+ unless ($host_servers{$course_server}) {
+ return 'error: invalid home server for course: '.$course_server;
}
# ------------------------------------------------------------- Make the course
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
@@ -6696,8 +6936,13 @@ ENDINITMAP
}
# ----------------------------------------------------------- Write preferences
&writecoursepref($udom.'_'.$uname,
- ('description' => $description,
- 'url' => $topurl));
+ ('description' => $description,
+ 'url' => $topurl,
+ 'internal.creator' => $env{'user.name'}.':'.
+ $env{'user.domain'},
+ 'internal.created' => $now,
+ 'internal.creationcontext' => $context)
+ );
return '/'.$udom.'/'.$uname;
}
@@ -7983,6 +8228,7 @@ sub add_prefix_and_part {
# ---------------------------------------------------------------- Get metadata
my %metaentry;
+my %importedpartids;
sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
@@ -8009,6 +8255,10 @@ sub metadata {
if (defined($cached)) { return $result->{':'.$what}; }
}
{
+# Imported parts would go here
+ my %importedids=();
+ my @origfileimportpartids=();
+ my $importedparts=0;
#
# Is this a recursive call for a library?
#
@@ -8092,27 +8342,55 @@ sub metadata {
# This is not a package - some other kind of start tag
#
my $entry=$token->[1];
- my $unikey;
- if ($entry eq 'import') {
- $unikey='';
- } else {
- $unikey=$entry;
- }
- $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
-
- if (defined($token->[2]->{'id'})) {
- $unikey.='_'.$token->[2]->{'id'};
- }
+ my $unikey='';
if ($entry eq 'import') {
#
# Importing a library here
#
+ my $location=$parser->get_text('/import');
+ my $dir=$filename;
+ $dir=~s|[^/]*$||;
+ $location=&filelocation($dir,$location);
+
+ my $importmode=$token->[2]->{'importmode'};
+ if ($importmode eq 'problem') {
+# Import as problem/response
+ $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+ } elsif ($importmode eq 'part') {
+# Import as part(s)
+ $importedparts=1;
+# We need to get the original file and the imported file to get the part order correct
+# Good news: we do not need to worry about nested libraries, since parts cannot be nested
+# Load and inspect original file
+ if ($#origfileimportpartids<0) {
+ undef(%importedpartids);
+ my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+ my $origfile=&getfile($origfilelocation);
+ @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ }
+
+# Load and inspect imported file
+ my $impfile=&getfile($location);
+ my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ if ($#impfilepartids>=0) {
+# This problem had parts
+ $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
+ } else {
+# Importing by turning a single problem into a problem part
+# It gets the import-tags ID as part-ID
+ $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
+ $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
+ }
+ } else {
+# Normal import
+ $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+ if (defined($token->[2]->{'id'})) {
+ $unikey.='_'.$token->[2]->{'id'};
+ }
+ }
+
if ($depthcount<20) {
- my $location=$parser->get_text('/import');
- my $dir=$filename;
- $dir=~s|[^/]*$||;
- $location=&filelocation($dir,$location);
my $metadata =
&metadata($uri,'keys', $location,$unikey,
$depthcount+1);
@@ -8120,9 +8398,16 @@ sub metadata {
$metaentry{':'.$meta}=$metaentry{':'.$meta};
$metathesekeys{$meta}=1;
}
- }
- } else {
+ }
+ } else {
+#
+# Not importing, some other kind of non-package, non-library start tag
+#
+ $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
+ if (defined($token->[2]->{'id'})) {
+ $unikey.='_'.$token->[2]->{'id'};
+ }
if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};
}
@@ -8196,6 +8481,22 @@ sub metadata {
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
$metaentry{':packages'} = join(',',@uniq_packages);
+ if ($importedparts) {
+# We had imported parts and need to rebuild partorder
+ $metaentry{':partorder'}='';
+ $metathesekeys{'partorder'}=1;
+ for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
+ if ($origfileimportpartids[$index] eq 'part') {
+# original part, part of the problem
+ $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
+ } else {
+# we have imported parts at this position
+ $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
+ }
+ }
+ $metaentry{':partorder'}=~s/^\,//;
+ }
+
$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
@@ -9556,6 +9857,12 @@ sub get_dns {
return %libserv;
}
+ sub unique_library {
+ #2x reverse removes all hostnames that appear more than once
+ my %unique = reverse &all_library();
+ return reverse %unique;
+ }
+
sub get_servers {
&load_hosts_tab() if (!$loaded);
@@ -9579,6 +9886,11 @@ sub get_dns {
return %result;
}
+ sub get_unique_servers {
+ my %unique = reverse &get_servers(@_);
+ return reverse %unique;
+ }
+
sub host_domain {
&load_hosts_tab() if (!$loaded);
@@ -9787,6 +10099,24 @@ BEGIN {
close($config);
}
+# ---------------------------------------------------------- Read loncaparev table
+{
+ if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
+ if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
+ while (my $configline=<$config>) {
+ chomp($configline);
+ my ($hostid,$loncaparev)=split(/:/,$configline);
+ $loncaparevs{$hostid}=$loncaparev;
+ }
+ close($config);
+ }
+ }
+}
+
+sub all_loncaparevs {
+ return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);
+}
+
# ------------- set up temporary directory
{
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
@@ -10017,9 +10347,14 @@ authentication scheme
=item *
X<authenticate()>
-B<authenticate($uname,$upass,$udom)>: try to
+B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to
authenticate user from domain's lib servers (first use the current
one). C<$upass> should be the users password.
+$checkdefauth is optional (value is 1 if a check should be made to
+ authenticate user using default authentication method, and allow
+ account creation if username does not have account in the domain).
+$clientcancheckhost is optional (value is 1 if checking whether the
+ server can host will occur on the client side in lonauth.pm).
=item *
X<homeserver()>
@@ -10141,9 +10476,16 @@ modifyuserauth($udom,$uname,$umode,$upas
=item *
-modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
- $forceid,$desiredhome,$email,$inststatus) :
-modify user
+modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene,
+ $forceid,$desiredhome,$email,$inststatus,$candelete) :
+
+will update user information (firstname,middlename,lastname,generation,
+permanentemail), and if forceid is true, student/employee ID also.
+A user's institutional affiliation(s) can also be updated.
+User information fields will not be overwritten with empty entries
+unless the field is included in the $candelete array reference.
+This array is included when a single user is modified via "Manage Users",
+or when Autoupdate.pl is run by cron in a domain.
=item *