--- loncom/lonnet/perl/lonnet.pm 2016/09/27 18:04:52 1.1325
+++ loncom/lonnet/perl/lonnet.pm 2017/01/28 23:26:51 1.1336
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1325 2016/09/27 18:04:52 raeburn Exp $
+# $Id: lonnet.pm,v 1.1336 2017/01/28 23:26:51 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -1049,7 +1049,7 @@ sub choose_server {
if ($login_host ne '') {
$hostname = &hostname($login_host);
}
- return ($login_host,$hostname,$portal_path,$isredirect);
+ return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
}
# --------------------------------------------- Try to change a user's password
@@ -1321,7 +1321,7 @@ sub get_lonbalancer_config {
}
sub check_loadbalancing {
- my ($uname,$udom) = @_;
+ my ($uname,$udom,$caller) = @_;
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
$rule_in_effect,$offloadto,$otherserver);
my $lonhost = $perlvar{'lonHostID'};
@@ -1472,13 +1472,15 @@ sub check_loadbalancing {
}
}
}
- if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
- $is_balancer = 0;
- if ($uname ne '' && $udom ne '') {
- if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
+ unless ($caller eq 'login') {
+ if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
+ $is_balancer = 0;
+ if ($uname ne '' && $udom ne '') {
+ if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
- &appenv({'user.loadbalexempt' => $lonhost,
- 'user.loadbalcheck.time' => time});
+ &appenv({'user.loadbalexempt' => $lonhost,
+ 'user.loadbalcheck.time' => time});
+ }
}
}
}
@@ -2245,7 +2247,7 @@ sub get_domain_defaults {
'coursedefaults','usersessions',
'requestauthor','selfenrollment',
'coursecategories','ssl','autoenroll',
- 'trust'],$domain);
+ 'trust','helpsettings'],$domain);
my @coursetypes = ('official','unofficial','community','textbook','placement');
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
@@ -2390,6 +2392,12 @@ sub get_domain_defaults {
if (ref($domconfig{'autoenroll'}) eq 'HASH') {
$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
}
+ if (ref($domconfig{'helpsettings'}) eq 'HASH') {
+ $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
+ if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') {
+ $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
+ }
+ }
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;
}
@@ -4108,7 +4116,7 @@ sub flushcourselogs {
}
}
#
-# Reverse lookup of domain roles (dc, ad, li, sc, au)
+# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au)
#
my %domrolebuffer = ();
foreach my $entry (keys(%domainrolehash)) {
@@ -4255,7 +4263,7 @@ sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
=$tend.':'.$tstart;
}
- if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
+ if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$domainrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
@@ -4482,6 +4490,195 @@ sub get_my_roles {
return %returnhash;
}
+sub get_all_adhocroles {
+ my ($dom) = @_;
+ my @roles_by_num = ();
+ my %domdefaults = &get_domain_defaults($dom);
+ my (%description,%access_in_dom,%access_info);
+ if (ref($domdefaults{'adhocroles'}) eq 'HASH') {
+ my $count = 0;
+ my %domcurrent = %{$domdefaults{'adhocroles'}};
+ my %ordered;
+ foreach my $role (sort(keys(%domcurrent))) {
+ my ($order,$desc,$access_in_dom);
+ if (ref($domcurrent{$role}) eq 'HASH') {
+ $order = $domcurrent{$role}{'order'};
+ $desc = $domcurrent{$role}{'desc'};
+ $access_in_dom{$role} = $domcurrent{$role}{'access'};
+ $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}};
+ }
+ if ($order eq '') {
+ $order = $count;
+ }
+ $ordered{$order} = $role;
+ if ($desc ne '') {
+ $description{$role} = $desc;
+ } else {
+ $description{$role}= $role;
+ }
+ $count++;
+ }
+ foreach my $item (sort {$a <=> $b } (keys(%ordered))) {
+ push(@roles_by_num,$ordered{$item});
+ }
+ }
+ return (\@roles_by_num,\%description,\%access_in_dom,\%access_info);
+}
+
+sub get_my_adhocroles {
+ my ($cid,$checkreg) = @_;
+ my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num);
+ if ($env{'request.course.id'} eq $cid) {
+ $cdom = $env{'course.'.$cid.'.domain'};
+ $cnum = $env{'course.'.$cid.'.num'};
+ $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'};
+ } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
+ $cdom = $1;
+ $cnum = $2;
+ %info = &Apache::lonnet::get('environment',['internal.coursecode'],
+ $cdom,$cnum);
+ }
+ if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
+ my $user = $env{'user.name'}.':'.$env{'user.domain'};
+ my %rosterhash = &get('classlist',[$user],$cdom,$cnum);
+ if ($rosterhash{$user} ne '') {
+ my $type = (split(/:/,$rosterhash{$user}))[5];
+ return ([],{}) if ($type eq 'auto');
+ }
+ }
+ if (($cdom ne '') && ($cnum ne '')) {
+ if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) {
+ my $then=$env{'user.login.time'};
+ my $update=$env{'user.update.time'};
+ if (!$update) {
+ $update = $then;
+ }
+ my @liveroles;
+ foreach my $role ('dh','da') {
+ if ($env{"user.role.$role./$cdom/"}) {
+ my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"});
+ my $limit = $update;
+ if ($env{'request.role'} eq "$role./$cdom/") {
+ $limit = $then;
+ }
+ my $activerole = 1;
+ if ($tstart && $tstart>$limit) { $activerole = 0; }
+ if ($tend && $tend <$limit) { $activerole = 0; }
+ if ($activerole) {
+ push(@liveroles,$role);
+ }
+ }
+ }
+ if (@liveroles) {
+ if (&homeserver($cnum,$cdom) ne 'no_host') {
+ my ($accessref,$accessinfo,%access_in_dom);
+ ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom);
+ if (ref($roles_by_num) eq 'ARRAY') {
+ if (@{$roles_by_num}) {
+ my %settings;
+ if ($env{'request.course.id'} eq $cid) {
+ foreach my $envkey (keys(%env)) {
+ if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) {
+ $settings{$1} = $env{$envkey};
+ }
+ }
+ } else {
+ %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc');
+ }
+ my %setincrs;
+ if ($settings{'internal.adhocaccess'}) {
+ map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'});
+ }
+ my @statuses;
+ if ($env{'environment.inststatus'}) {
+ @statuses = split(/,/,$env{'environment.inststatus'});
+ }
+ my $user = $env{'user.name'}.':'.$env{'user.domain'};
+ if (ref($accessref) eq 'HASH') {
+ %access_in_dom = %{$accessref};
+ }
+ foreach my $role (@{$roles_by_num}) {
+ my ($curraccess,@okstatus,@personnel);
+ if ($setincrs{$role}) {
+ ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role});
+ if ($curraccess eq 'status') {
+ @okstatus = split(/\&/,$rest);
+ } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
+ @personnel = split(/\&/,$rest);
+ }
+ } else {
+ $curraccess = $access_in_dom{$role};
+ if (ref($accessinfo) eq 'HASH') {
+ if ($curraccess eq 'status') {
+ if (ref($accessinfo->{$role}) eq 'ARRAY') {
+ @okstatus = @{$accessinfo->{$role}};
+ }
+ } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
+ if (ref($accessinfo->{$role}) eq 'ARRAY') {
+ @personnel = @{$accessinfo->{$role}};
+ }
+ }
+ }
+ }
+ if ($curraccess eq 'none') {
+ next;
+ } elsif ($curraccess eq 'all') {
+ push(@possroles,$role);
+ } elsif ($curraccess eq 'dh') {
+ if (grep(/^dh$/,@liveroles)) {
+ push(@possroles,$role);
+ } else {
+ next;
+ }
+ } elsif ($curraccess eq 'da') {
+ if (grep(/^da$/,@liveroles)) {
+ push(@possroles,$role);
+ } else {
+ next;
+ }
+ } elsif ($curraccess eq 'status') {
+ if (@okstatus) {
+ if (!@statuses) {
+ if (grep(/^default$/,@okstatus)) {
+ push(@possroles,$role);
+ }
+ } else {
+ foreach my $status (@okstatus) {
+ if (grep(/^\Q$status\E$/,@statuses)) {
+ push(@possroles,$role);
+ last;
+ }
+ }
+ }
+ }
+ } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
+ if (grep(/^\Q$user\E$/,@personnel)) {
+ if ($curraccess eq 'exc') {
+ push(@possroles,$role);
+ }
+ } elsif ($curraccess eq 'inc') {
+ push(@possroles,$role);
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ unless (ref($description) eq 'HASH') {
+ if (ref($roles_by_num) eq 'ARRAY') {
+ my %desc;
+ map { $desc{$_} = $_; } (@{$roles_by_num});
+ $description = \%desc;
+ } else {
+ $description = {};
+ }
+ }
+ return (\@possroles,$description);
+}
+
# ----------------------------------------------------- Frontpage Announcements
#
#
@@ -4722,6 +4919,21 @@ sub get_domain_roles {
return %personnel;
}
+sub get_active_domroles {
+ my ($dom,$roles) = @_;
+ return () unless (ref($roles) eq 'ARRAY');
+ my $now = time;
+ my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now);
+ my %domroles;
+ foreach my $server (keys(%dompersonnel)) {
+ foreach my $user (sort(keys(%{$dompersonnel{$server}}))) {
+ my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user);
+ $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user};
+ }
+ }
+ return %domroles;
+}
+
# ----------------------------------------------------------- Interval timing
{
@@ -5614,6 +5826,10 @@ sub custom_roleprivs {
$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
}
if (($trest ne '') && (defined($coursepriv))) {
+ if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) {
+ my $rolename = $1;
+ $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv);
+ }
$$allroles{'cm.'.$area}.=':'.$coursepriv;
$$allroles{$spec.'.'.$area}.=':'.$coursepriv;
}
@@ -5622,6 +5838,48 @@ sub custom_roleprivs {
}
}
+sub course_adhocrole_privs {
+ my ($rolename,$cdom,$cnum,$coursepriv) = @_;
+ my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum);
+ if ($overrides{"internal.adhocpriv.$rolename"}) {
+ my (%currprivs,%storeprivs);
+ foreach my $item (split(/:/,$coursepriv)) {
+ my ($priv,$restrict) = split(/\&/,$item);
+ $currprivs{$priv} = $restrict;
+ }
+ my (%possadd,%possremove,%full);
+ foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) {
+ my ($priv,$restrict)=split(/\&/,$item);
+ $full{$priv} = $restrict;
+ }
+ foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
+ next if ($item eq '');
+ my ($rule,$rest) = split(/=/,$item);
+ next unless (($rule eq 'off') || ($rule eq 'on'));
+ foreach my $priv (split(/:/,$rest)) {
+ if ($priv ne '') {
+ if ($rule eq 'off') {
+ $possremove{$priv} = 1;
+ } else {
+ $possadd{$priv} = 1;
+ }
+ }
+ }
+ }
+ foreach my $priv (sort(keys(%full))) {
+ if (exists($currprivs{$priv})) {
+ unless (exists($possremove{$priv})) {
+ $storeprivs{$priv} = $currprivs{$priv};
+ }
+ } elsif (exists($possadd{$priv})) {
+ $storeprivs{$priv} = $full{$priv};
+ }
+ }
+ $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
+ }
+ return $coursepriv;
+}
+
sub group_roleprivs {
my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
my $access = 1;
@@ -5834,39 +6092,56 @@ sub delete_env_groupprivs {
}
sub check_adhoc_privs {
- my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
+ my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_;
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
+ if ($sec) {
+ $cckey .= '/'.$sec;
+ }
my $setprivs;
if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
- &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
+ &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
$setprivs = 1;
}
} else {
- &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
+ &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
$setprivs = 1;
}
return $setprivs;
}
sub set_adhoc_privileges {
-# role can be cc or ca
- my ($dcdom,$pickedcourse,$role,$caller) = @_;
+# role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role
+ my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_;
my $area = '/'.$dcdom.'/'.$pickedcourse;
+ if ($sec ne '') {
+ $area .= '/'.$sec;
+ }
my $spec = $role.'.'.$area;
my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
$env{'user.name'},1);
- my %ccrole = ();
- &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
- my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
+ my %rolehash = ();
+ if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) {
+ my $rolename = $1;
+ &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area);
+ my %domdef = &get_domain_defaults($dcdom);
+ if (ref($domdef{'adhocroles'}) eq 'HASH') {
+ if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') {
+ &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},});
+ }
+ }
+ } else {
+ &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area);
+ }
+ my ($author,$adv)= &set_userprivs(\%userroles,\%rolehash);
&appenv(\%userroles,[$role,'cm']);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,
- 'request.course.sec' => ''
+ 'request.course.sec' => $sec,
}
);
my $tadv=0;
@@ -6250,9 +6525,11 @@ sub tmpget {
if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
my $rep=&reply("tmpget:$token",$server);
my %returnhash;
+ if ($rep =~ /^(con_lost|error|no_such_host)/i) {
+ return %returnhash;
+ }
foreach my $item (split(/\&/,$rep)) {
my ($key,$value)=split(/=/,$item);
- next if ($key =~ /^error: 2 /);
$returnhash{&unescape($key)}=&thaw_unescape($value);
}
return %returnhash;
@@ -7784,7 +8061,7 @@ sub get_symb_from_alias {
sub definerole {
if (allowed('mcr','/')) {
- my ($rolename,$sysrole,$domrole,$courole)=@_;
+ my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_;
foreach my $role (split(':',$sysrole)) {
my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
@@ -7812,11 +8089,19 @@ sub definerole {
}
}
}
+ my $uhome;
+ if (($uname ne '') && ($udom ne '')) {
+ $uhome = &homeserver($uname,$udom);
+ return $uhome if ($uhome eq 'no_host');
+ } else {
+ $uname = $env{'user.name'};
+ $udom = $env{'user.domain'};
+ $uhome = $env{'user.home'};
+ }
my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
- "$env{'user.domain'}:$env{'user.name'}:".
- "rolesdef_$rolename=".
+ "$udom:$uname:rolesdef_$rolename=".
escape($sysrole.'_'.$domrole.'_'.$courole);
- return reply($command,$env{'user.home'});
+ return reply($command,$uhome);
} else {
return 'refused';
}
@@ -8865,7 +9150,8 @@ sub assignrole {
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$selfenroll,$context);
} elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
- ($role eq 'au') || ($role eq 'dc')) {
+ ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') ||
+ ($role eq 'da')) {
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$context);
} elsif (($role eq 'ca') || ($role eq 'aa')) {
@@ -13756,9 +14042,10 @@ in which case the null string is returne
=item *
-definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
-role rolename set privileges in format of lonTabs/roles.tab for system, domain,
-and course level
+definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role;
+define a custom role rolename set privileges in format of lonTabs/roles.tab
+for system, domain, and course level. $uname and $udom are optional (current
+user's username and domain will be used when either of $uname or $udom are absent.
=item *