--- loncom/lonnet/perl/lonnet.pm 2001/12/28 19:48:42 1.195
+++ loncom/lonnet/perl/lonnet.pm 2002/02/25 14:33:58 1.203
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.195 2001/12/28 19:48:42 www Exp $
+# $Id: lonnet.pm,v 1.203 2002/02/25 14:33:58 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -65,6 +65,8 @@
# 12/6,12/7,12/12 Gerd Kortemeyer
# 12/18 Scott Harrison
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer
+# YEAR=2002
+# 1/4,2/4,2/7 Gerd Kortemeyer
#
###
@@ -78,7 +80,7 @@ use vars
qw(%perlvar %hostname %homecache %hostip %spareid %hostdom
%libserv %pr %prp %metacache %packagetab
%courselogs %accesshash $processmarker $dumpcount
- %coursedombuf %coursehombuf);
+ %coursedombuf %coursehombuf %courseresdatacache);
use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
@@ -136,7 +138,22 @@ sub subreply {
sub reply {
my ($cmd,$server)=@_;
my $answer=subreply($cmd,$server);
- if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
+ if ($answer eq 'con_lost') {
+ sleep 5;
+ $answer=subreply($cmd,$server);
+ if ($answer eq 'con_lost') {
+ &logthis("Second attempt con_lost on $server");
+ my $peerfile="$perlvar{'lonSockDir'}/$server";
+ my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
+ Type => SOCK_STREAM,
+ Timeout => 10)
+ or return "con_lost";
+ &logthis("Killing socket");
+ print $client "close_connection_exit\n";
+ sleep 5;
+ $answer=subreply($cmd,$server);
+ }
+ }
if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
&logthis("<font color=blue>WARNING:".
" $cmd to $server returned $answer</font>");
@@ -346,6 +363,41 @@ sub spareserver {
return $spareserver;
}
+# --------------------------------------------- Try to change a user's password
+
+sub changepass {
+ my ($uname,$udom,$currentpass,$newpass,$server)=@_;
+ $currentpass = &escape($currentpass);
+ $newpass = &escape($newpass);
+ my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
+ $server);
+ if (! $answer) {
+ &logthis("No reply on password change request to $server ".
+ "by $uname in domain $udom.");
+ } elsif ($answer =~ "^ok") {
+ &logthis("$uname in $udom successfully changed their password ".
+ "on $server.");
+ } elsif ($answer =~ "^pwchange_failure") {
+ &logthis("$uname in $udom was unable to change their password ".
+ "on $server. The action was blocked by either lcpasswd ".
+ "or pwchange");
+ } elsif ($answer =~ "^non_authorized") {
+ &logthis("$uname in $udom did not get their password correct when ".
+ "attempting to change it on $server.");
+ } elsif ($answer =~ "^auth_mode_error") {
+ &logthis("$uname in $udom attempted to change their password despite ".
+ "not being locally or internally authenticated on $server.");
+ } elsif ($answer =~ "^unknown_user") {
+ &logthis("$uname in $udom attempted to change their password ".
+ "on $server but were unable to because $server is not ".
+ "their home server.");
+ } elsif ($answer =~ "^refused") {
+ &logthis("$server refused to change $uname in $udom password because ".
+ "it was sent an unencrypted request to change the password.");
+ }
+ return $answer;
+}
+
# ----------------------- Try to determine user's current authentication scheme
sub queryauthenticate {
@@ -389,6 +441,7 @@ sub queryauthenticate {
sub authenticate {
my ($uname,$upass,$udom)=@_;
$upass=escape($upass);
+ $uname=~s/\W//g;
if (($perlvar{'lonRole'} eq 'library') &&
($udom eq $perlvar{'lonDefDomain'})) {
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
@@ -638,7 +691,7 @@ sub ssi {
if (%form) {
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
- $request->content(join '&', map { "$_=$form{$_}" } keys %form);
+ $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
} else {
$request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
}
@@ -1704,14 +1757,25 @@ sub assignrole {
}
# -------------------------------------------------- Modify user authentication
+# Overrides without validation
+
sub modifyuserauth {
my ($udom,$uname,$umode,$upass)=@_;
my $uhome=&homeserver($uname,$udom);
- &logthis('Call to modify user authentication'.$udom.', '.$uname.', '.
+ unless (&allowed('mau',$udom)) { return 'refused'; }
+ &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
$umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
&escape($upass),$uhome);
+ &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
+ 'Authentication changed for '.$udom.', '.$uname.', '.$umode.
+ '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
+ &log($udom,,$uname,$uhome,
+ 'Authentication changed by '.$ENV{'user.domain'}.', '.
+ $ENV{'user.name'}.', '.$umode.
+ '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
unless ($reply eq 'ok') {
+ &logthis('Authentication mode error: '.$reply);
return 'error: '.$reply;
}
return 'ok';
@@ -1721,10 +1785,13 @@ sub modifyuserauth {
sub modifyuser {
- my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
+ my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
+ $forceid)=@_;
+ $udom=~s/\W//g;
+ $uname=~s/\W//g;
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.' by '.
+ $last.', '.$gene.'(forceid: '.$forceid.') by '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'});
my $uhome=&homeserver($uname,$udom);
# ----------------------------------------------------------------- Create User
@@ -1762,7 +1829,8 @@ sub modifyuser {
if ($uid) {
$uid=~tr/A-Z/a-z/;
my %uidhash=&idrget($udom,$uname);
- if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) {
+ if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)
+ && (!$forceid)) {
unless ($uid eq $uidhash{$uname}) {
return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
}
@@ -1791,14 +1859,14 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
- $end,$start)=@_;
+ $end,$start,$forceid)=@_;
my $cid='';
unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';
}
# --------------------------------------------------------------- Make the user
my $reply=&modifyuser
- ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene);
+ ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid);
unless ($reply eq 'ok') { return $reply; }
my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
@@ -2006,6 +2074,38 @@ sub condval {
return $result;
}
+# --------------------------------------------------- Course Resourcedata Query
+
+sub courseresdata {
+ my ($coursenum,$coursedomain,@which)=@_;
+ my $coursehom=&homeserver($coursenum,$coursedomain);
+ my $hashid=$coursenum.':'.$coursedomain;
+ unless (defined($courseresdatacache{$hashid.'.time'})) {
+ unless (time-$courseresdatacache{$hashid.'.time'}<300) {
+ my $coursehom=&homeserver($coursenum,$coursedomain);
+ if ($coursehom) {
+ my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum.
+ ':resourcedata:.',$coursehom);
+ unless ($dumpreply=~/^error\:/) {
+ $courseresdatacache{$hashid.'.time'}=time;
+ $courseresdatacache{$hashid}=$dumpreply;
+ }
+ }
+ }
+ }
+ my @pairs=split(/\&/,$courseresdatacache{$hashid});
+ my %returnhash=();
+ foreach (@pairs) {
+ my ($key,$value)=split(/=/,$_);
+ $returnhash{unescape($key)}=unescape($value);
+ }
+ my $item;
+ foreach $item (@which) {
+ if ($returnhash{$item}) { return $returnhash{$item}; }
+ }
+ return '';
+}
+
# --------------------------------------------------------- Value of a Variable
sub EXT {
@@ -2126,28 +2226,13 @@ sub EXT {
# -------------------------------------------------------- second, check course
- my $reply=&reply('get:'.
- $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
- $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
- ':resourcedata:'.
- &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
- &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
- $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
- if ($reply!~/^error\:/) {
- foreach (split(/\&/,$reply)) {
- if ($_) { return &unescape($_); }
- }
- }
- if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
- &logthis("<font color=blue>WARNING:".
- " Getting ".$reply." asking for ".$varname." for ".
- $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
- ' at '.
- $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
- ' from '.
- $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
- "</font>");
- }
+ my $coursereply=&courseresdata(
+ $ENV{'course.'.$ENV{'request.course.id'}.'.num'},
+ $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},
+ ($seclevelr,$seclevelm,$seclevel,
+ $courselevelr,$courselevelm,$courselevel));
+ if ($coursereply) { return $coursereply; }
+
# ------------------------------------------------------ third, check map parms
my %parmhash=();
my $thisparm='';