--- loncom/lonnet/perl/lonnet.pm 2007/01/29 21:16:55 1.831
+++ loncom/lonnet/perl/lonnet.pm 2007/03/02 23:17:40 1.838
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.831 2007/01/29 21:16:55 albertel Exp $
+# $Id: lonnet.pm,v 1.838 2007/03/02 23:17:40 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -35,7 +35,7 @@ use HTTP::Headers;
use HTTP::Date;
# use Date::Parse;
use vars
-qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
+qw(%perlvar %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
@@ -149,7 +149,7 @@ sub logperm {
# -------------------------------------------------- Non-critical communication
sub subreply {
my ($cmd,$server)=@_;
- my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
+ my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
#
# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX
@@ -189,7 +189,7 @@ sub subreply {
sub reply {
my ($cmd,$server)=@_;
- unless (defined($hostname{$server})) { return 'no_such_host'; }
+ unless (defined(&hostname($server))) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
&logthis("<font color=\"blue\">WARNING:".
@@ -201,8 +201,7 @@ sub reply {
# ----------------------------------------------------------- Send USR1 to lonc
sub reconlonc {
- my $peerfile=shift;
- &logthis("Trying to reconnect for $peerfile");
+ &logthis("Trying to reconnect lonc");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (open(my $fh,"<$loncfile")) {
my $loncpid=<$fh>;
@@ -211,19 +210,13 @@ sub reconlonc {
&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;
sleep 1;
- if (-e "$peerfile") { return; }
- &logthis("$peerfile still not there, give it another try");
- sleep 5;
- if (-e "$peerfile") { return; }
- &logthis(
- "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
- } else {
+ } else {
&logthis(
"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");
}
} else {
- &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
+ &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}
}
@@ -231,7 +224,7 @@ sub reconlonc {
sub critical {
my ($cmd,$server)=@_;
- unless ($hostname{$server}) {
+ unless (&hostname($server)) {
&logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");
return 'no_such_host';
@@ -524,7 +517,7 @@ sub spareserver {
}
if (!$want_server_name) {
- $spare_server="http://$hostname{$spare_server}";
+ $spare_server="http://".&hostname($spare_server);
}
return $spare_server;
}
@@ -615,9 +608,15 @@ sub authenticate {
my ($uname,$upass,$udom)=@_;
$upass=&escape($upass);
$uname= &LONCAPA::clean_username($uname);
- my $uhome=&homeserver($uname,$udom);
- if (!$uhome) {
- &logthis("User $uname at $udom is unknown in authenticate");
+ my $uhome=&homeserver($uname,$udom,1);
+ if ((!$uhome) || ($uhome eq 'no_host')) {
+# Maybe the machine was offline and only re-appeared again recently?
+ &reconlonc();
+# One more
+ my $uhome=&homeserver($uname,$udom,1);
+ if ((!$uhome) || ($uhome eq 'no_host')) {
+ &logthis("User $uname at $udom is unknown in authenticate");
+ }
return 'no_host';
}
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
@@ -647,7 +646,8 @@ sub homeserver {
exists($badServerCache{$tryserver}));
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);
- if ($answer eq 'found') {
+ if ($answer eq 'found') {
+ delete($badServerCache{$tryserver});
return $homecache{$index}=$tryserver;
} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;
@@ -766,6 +766,30 @@ sub put_dom {
}
}
+sub retrieve_inst_usertypes {
+ my ($udom) = @_;
+ my (%returnhash,@order);
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ my $rep=&reply("inst_usertypes:$udom",$uhome);
+ my ($hashitems,$orderitems) = split(/:/,$rep);
+ my @pairs=split(/\&/,$hashitems);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash{$key}=&thaw_unescape($value);
+ }
+ my @esc_order = split(/\&/,$orderitems);
+ foreach my $item (@esc_order) {
+ push(@order,&unescape($item));
+ }
+ } else {
+ &logthis("get_dom failed - no primary domain server for $udom");
+ }
+ return (\%returnhash,\@order);
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -2027,7 +2051,7 @@ sub get_course_adv_roles {
}
sub get_my_roles {
- my ($uname,$udom)=@_;
+ my ($uname,$udom,$types,$roles,$roledoms)=@_;
unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }
my %dumphash=
@@ -2037,11 +2061,35 @@ sub get_my_roles {
foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }
- if (($tend) && ($tend<$now)) { next; }
- if (($tstart) && ($now<$tstart)) { next; }
+ my $status = 'active';
+ if (($tend) && ($tend<$now)) {
+ $status = 'previous';
+ }
+ if (($tstart) && ($now<$tstart)) {
+ $status = 'future';
+ }
+ if (ref($types) eq 'ARRAY') {
+ if (!grep(/^\Q$status\E$/,@{$types})) {
+ next;
+ }
+ } else {
+ if ($status ne 'active') {
+ next;
+ }
+ }
my ($role,$username,$domain,$section)=split(/\:/,$entry);
+ if (ref($roledoms) eq 'ARRAY') {
+ if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
+ next;
+ }
+ }
+ if (ref($roles) eq 'ARRAY') {
+ if (!grep(/^\Q$role\E$/,@{$roles})) {
+ next;
+ }
+ }
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
- }
+ }
return %returnhash;
}
@@ -2247,7 +2295,7 @@ sub checkin {
my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;
- my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
+ my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
$dtoken=~s/\W/\_/g;
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
@@ -2916,7 +2964,7 @@ sub custom_roleprivs {
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
my $homsvr=homeserver($rauthor,$rdomain);
- if ($hostname{$homsvr} ne '') {
+ if (&hostname($homsvr) ne '') {
my ($rdummy,$roledef)=
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
if (($rdummy ne 'con_lost') && ($roledef ne '')) {
@@ -4147,7 +4195,7 @@ sub log_query {
my ($uname,$udom,$query,%filters)=@_;
my $uhome=&homeserver($uname,$udom);
if ($uhome eq 'no_host') { return 'error: no_host'; }
- my $uhost=$hostname{$uhome};
+ my $uhost=&hostname($uhome);
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);
@@ -4179,7 +4227,7 @@ sub fetch_enrollment_query {
} else {
$homeserver = &homeserver($cnum,$dom);
}
- my $host=$hostname{$homeserver};
+ my $host=&hostname($homeserver);
my $cmd = '';
foreach my $affiliate (keys %{$affiliatesref}) {
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
@@ -4370,7 +4418,7 @@ sub auto_photochoice {
sub auto_photoupdate {
my ($affiliatesref,$dom,$cnum,$photo) = @_;
my $homeserver = &homeserver($cnum,$dom);
- my $host=$hostname{$homeserver};
+ my $host=&hostname($homeserver);
my $cmd = '';
my $maxtries = 1;
foreach my $affiliate (keys(%{$affiliatesref})) {
@@ -5110,9 +5158,7 @@ sub is_locked {
sub declutter_portfile {
my ($file) = @_;
- &logthis("got $file");
- $file =~ s-^(/portfolio/|portfolio/)-/-;
- &logthis("ret $file");
+ $file =~ s{^(/portfolio/|portfolio/)}{/};
return $file;
}
@@ -7063,13 +7109,14 @@ sub setup_random_from_rndseed {
}
sub latest_receipt_algorithm_id {
- return 'receipt2';
+ return 'receipt3';
}
sub recunique {
my $fucourseid=shift;
my $unique;
- if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
+ if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
+ $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
$unique=$env{"course.$fucourseid.internal.encseed"};
} else {
$unique=$perlvar{'lonReceipt'};
@@ -7080,7 +7127,8 @@ sub recunique {
sub recprefix {
my $fucourseid=shift;
my $prefix;
- if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
+ if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'||
+ $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
$prefix=$env{"course.$fucourseid.internal.encpref"};
} else {
$prefix=$perlvar{'lonHostID'};
@@ -7090,15 +7138,23 @@ sub recprefix {
sub ireceipt {
my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
+
+ my $return =&recprefix($fucourseid).'-';
+
+ if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' ||
+ $env{'request.state'} eq 'construct') {
+ $return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
+ return $return;
+ }
+
my $cuname=unpack("%32C*",$funame);
my $cudom=unpack("%32C*",$fudom);
my $cucourseid=unpack("%32C*",$fucourseid);
my $cusymb=unpack("%32C*",$fusymb);
my $cunique=&recunique($fucourseid);
my $cpart=unpack("%32S*",$part);
- my $return =&recprefix($fucourseid).'-';
- if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
- $env{'request.state'} eq 'construct') {
+ if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
+
#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));
$return.= ($cunique%$cuname+
@@ -7230,7 +7286,7 @@ sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }
my $request;
$uri=~s/^\///;
- $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
+ $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);
# did it work?
if ($response->is_error()) {
@@ -7253,7 +7309,7 @@ sub tokenwrapper {
if ($udom && $uname && $file) {
$file=~s|(\?\.*)*$||;
&appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
- return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
+ return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -7268,7 +7324,7 @@ sub tokenwrapper {
sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
- $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
+ $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);
@@ -7358,8 +7414,9 @@ sub hreflocation {
}
sub current_machine_domains {
- my $hostname=$hostname{$perlvar{'lonHostID'}};
+ my $hostname=&hostname($perlvar{'lonHostID'});
my @domains;
+ my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {
@@ -7370,8 +7427,9 @@ sub current_machine_domains {
}
sub current_machine_ids {
- my $hostname=$hostname{$perlvar{'lonHostID'}};
+ my $hostname=&hostname($perlvar{'lonHostID'});
my @ids;
+ my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {
@@ -7549,6 +7607,7 @@ BEGIN {
# ------------------------------------------------------------- Read hosts file
{
+ my %hostname;
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
while (my $configline=<$config>) {
@@ -7565,11 +7624,20 @@ BEGIN {
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();
+
+ sub hostname {
+ my ($lonid) = @_;
+ return $hostname{$lonid};
+ }
+ sub all_hostnames {
+ return %hostname;
+ }
}
sub get_iphost {
if (%iphost) { return %iphost; }
my %name_to_ip;
+ my %hostname = &all_hostnames();
foreach my $id (keys(%hostname)) {
my $name=$hostname{$id};
my $ip;
@@ -7947,6 +8015,19 @@ and course level
plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
explanation of a user role term
+=item *
+
+get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are
+optional. Returns a hash of a user's roles, with keys set to
+colon-sparated $uname,$udom,and $role, and value set to
+colon-separated start and end times for the role. If no username and
+domain are specified, will default to current user/domain. Types,
+roles, and roledoms are references to arrays, of role statuses
+(active, future or previous), roles (e.g., cc,in, st etc.) and domains
+of the roles which can be used to restrict the list if roles
+reported. If no array ref is provided for types, will default to
+return only active roles.
+
=back
=head2 User Modification