|
version 1.264, 2004/10/26 14:55:49
|
version 1.279, 2005/02/17 08:57:51
|
|
Line 46 use Authen::Krb5;
|
Line 46 use Authen::Krb5;
|
| use lib '/home/httpd/lib/perl/'; |
use lib '/home/httpd/lib/perl/'; |
| use localauth; |
use localauth; |
| use localenroll; |
use localenroll; |
| |
use localstudentphoto; |
| use File::Copy; |
use File::Copy; |
| use LONCAPA::ConfigFileEdit; |
use LONCAPA::ConfigFileEdit; |
| use LONCAPA::lonlocal; |
use LONCAPA::lonlocal; |
|
Line 64 my $currentdomainid;
|
Line 65 my $currentdomainid;
|
| |
|
| my $client; |
my $client; |
| my $clientip; # IP address of client. |
my $clientip; # IP address of client. |
| my $clientdns; # DNS name of client. |
|
| my $clientname; # LonCAPA name of client. |
my $clientname; # LonCAPA name of client. |
| |
|
| my $server; |
my $server; |
|
Line 177 sub ResetStatistics {
|
Line 177 sub ResetStatistics {
|
| # $initcmd - The full text of the init command. |
# $initcmd - The full text of the init command. |
| # |
# |
| # Implicit inputs: |
# Implicit inputs: |
| # $clientdns - The DNS name of the remote client. |
|
| # $thisserver - Our DNS name. |
# $thisserver - Our DNS name. |
| # |
# |
| # Returns: |
# Returns: |
|
Line 186 sub ResetStatistics {
|
Line 185 sub ResetStatistics {
|
| # |
# |
| sub LocalConnection { |
sub LocalConnection { |
| my ($Socket, $initcmd) = @_; |
my ($Socket, $initcmd) = @_; |
| Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver"); |
Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver"); |
| if($clientdns ne $thisserver) { |
if($clientip ne "127.0.0.1") { |
| &logthis('<font color="red"> LocalConnection rejecting non local: ' |
&logthis('<font color="red"> LocalConnection rejecting non local: ' |
| ."$clientdns ne $thisserver </font>"); |
."$clientip ne $thisserver </font>"); |
| close $Socket; |
close $Socket; |
| return undef; |
return undef; |
| } else { |
} else { |
|
Line 1311 sub user_authorization_type {
|
Line 1310 sub user_authorization_type {
|
| my ($type,$otherinfo) = split(/:/,$result); |
my ($type,$otherinfo) = split(/:/,$result); |
| if($type =~ /^krb/) { |
if($type =~ /^krb/) { |
| $type = $result; |
$type = $result; |
| } |
} else { |
| &Reply( $replyfd, "$type:\n", $userinput); |
$type .= ':'; |
| |
} |
| |
&Reply( $replyfd, "$type\n", $userinput); |
| } |
} |
| |
|
| return 1; |
return 1; |
|
Line 1796 sub change_authentication_handler {
|
Line 1797 sub change_authentication_handler {
|
| # to take ownership of the construction space back to www:www |
# to take ownership of the construction space back to www:www |
| # |
# |
| |
|
| if( ($oldauth =~ /^unix/) && ($umode eq "internal")) { # unix -> internal |
if( (($oldauth =~ /^unix/) && ($umode eq "internal")) || |
| |
(($oldauth =~ /^internal/) && ($umode eq "unix")) ) { |
| if(&is_author($udom, $uname)) { |
if(&is_author($udom, $uname)) { |
| &Debug(" Need to manage author permissions..."); |
&Debug(" Need to manage author permissions..."); |
| &manage_permissions("/$udom/_au", $udom, $uname, "internal:"); |
&manage_permissions("/$udom/_au", $udom, $uname, "$umode:"); |
| } |
} |
| } |
} |
| |
|
|
Line 1959 sub fetch_user_file_handler {
|
Line 1961 sub fetch_user_file_handler {
|
| # Note that any regular files in the way of this path are |
# Note that any regular files in the way of this path are |
| # wiped out to deal with some earlier folly of mine. |
# wiped out to deal with some earlier folly of mine. |
| |
|
| if (!&mkpath($udir.'/')) { |
if (!&mkpath($udir.'/'.$ufile)) { |
| &Failure($client, "unable_to_create\n", $userinput); |
&Failure($client, "unable_to_create\n", $userinput); |
| } |
} |
| |
|
|
Line 2834 sub store_handler {
|
Line 2836 sub store_handler {
|
| chomp($what); |
chomp($what); |
| my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
| my $hashref = &tie_user_hash($udom, $uname, $namespace, |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
| &GDBM_WRCREAT(), "P", |
&GDBM_WRCREAT(), "S", |
| "$rid:$what"); |
"$rid:$what"); |
| if ($hashref) { |
if ($hashref) { |
| my $now = time; |
my $now = time; |
|
Line 3105 sub reply_query_handler {
|
Line 3107 sub reply_query_handler {
|
| # $tail - Tail of the command. In this case consists of a colon |
# $tail - Tail of the command. In this case consists of a colon |
| # separated list contaning the domain to apply this to and |
# separated list contaning the domain to apply this to and |
| # an ampersand separated list of keyword=value pairs. |
# an ampersand separated list of keyword=value pairs. |
| |
# Each value is a colon separated list that includes: |
| |
# description, institutional code and course owner. |
| |
# For backward compatibility with versions included |
| |
# in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional |
| |
# code and/or course owner are preserved from the existing |
| |
# record when writing a new record in response to 1.1 or |
| |
# 1.2 implementations of lonnet::flushcourselogs(). |
| |
# |
| # $client - Socket open on the client. |
# $client - Socket open on the client. |
| # Returns: |
# Returns: |
| # 1 - indicating that processing should continue |
# 1 - indicating that processing should continue |
|
Line 3118 sub put_course_id_handler {
|
Line 3128 sub put_course_id_handler {
|
| |
|
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
| |
|
| my ($udom, $what) = split(/:/, $tail); |
my ($udom, $what) = split(/:/, $tail,2); |
| chomp($what); |
chomp($what); |
| my $now=time; |
my $now=time; |
| my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
|
Line 3126 sub put_course_id_handler {
|
Line 3136 sub put_course_id_handler {
|
| my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); |
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); |
| if ($hashref) { |
if ($hashref) { |
| foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
| my ($key,$descr,$inst_code)=split(/=/,$pair); |
my ($key,$courseinfo) = split(/=/,$pair,2); |
| $hashref->{$key}=$descr.':'.$inst_code.':'.$now; |
$courseinfo =~ s/=/:/g; |
| |
|
| |
my @current_items = split(/:/,$hashref->{$key}); |
| |
shift(@current_items); # remove description |
| |
pop(@current_items); # remove last access |
| |
my $numcurrent = scalar(@current_items); |
| |
|
| |
my @new_items = split(/:/,$courseinfo); |
| |
my $numnew = scalar(@new_items); |
| |
if ($numcurrent > 0) { |
| |
if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier |
| |
$courseinfo .= ':'.join(':',@current_items); |
| |
} elsif ($numnew == 2) { # flushcourselogs() from 1.2.X |
| |
$courseinfo .= ':'.$current_items[$numcurrent-1]; |
| |
} |
| |
} |
| |
$hashref->{$key}=$courseinfo.':'.$now; |
| } |
} |
| if (untie(%$hashref)) { |
if (untie(%$hashref)) { |
| &Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
|
Line 3165 sub put_course_id_handler {
|
Line 3191 sub put_course_id_handler {
|
| # description - regular expression that is used to filter |
# description - regular expression that is used to filter |
| # the dump. Only keywords matching this regexp |
# the dump. Only keywords matching this regexp |
| # will be used. |
# will be used. |
| |
# institutional code - optional supplied code to filter |
| |
# the dump. Only courses with an institutional code |
| |
# that match the supplied code will be returned. |
| |
# owner - optional supplied username of owner to filter |
| |
# the dump. Only courses for which the course |
| |
# owner matches the supplied username will be |
| |
# returned. Implicit assumption that owner |
| |
# is a user in the domain in which the |
| |
# course database is defined. |
| # $client - The socket open on the client. |
# $client - The socket open on the client. |
| # Returns: |
# Returns: |
| # 1 - Continue processing. |
# 1 - Continue processing. |
|
Line 3175 sub dump_course_id_handler {
|
Line 3210 sub dump_course_id_handler {
|
| |
|
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
| |
|
| my ($udom,$since,$description) =split(/:/,$tail); |
my ($udom,$since,$description,$instcodefilter,$ownerfilter) =split(/:/,$tail); |
| if (defined($description)) { |
if (defined($description)) { |
| $description=&unescape($description); |
$description=&unescape($description); |
| } else { |
} else { |
| $description='.'; |
$description='.'; |
| } |
} |
| |
if (defined($instcodefilter)) { |
| |
$instcodefilter=&unescape($instcodefilter); |
| |
} else { |
| |
$instcodefilter='.'; |
| |
} |
| |
if (defined($ownerfilter)) { |
| |
$ownerfilter=&unescape($ownerfilter); |
| |
} else { |
| |
$ownerfilter='.'; |
| |
} |
| |
|
| unless (defined($since)) { $since=0; } |
unless (defined($since)) { $since=0; } |
| my $qresult=''; |
my $qresult=''; |
| my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); |
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); |
| if ($hashref) { |
if ($hashref) { |
| while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
| my ($descr,$lasttime,$inst_code); |
my ($descr,$lasttime,$inst_code,$owner); |
| if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { |
my @courseitems = split(/:/,$value); |
| ($descr,$inst_code,$lasttime)=($1,$2,$3); |
$lasttime = pop(@courseitems); |
| } else { |
($descr,$inst_code,$owner)=@courseitems; |
| ($descr,$lasttime) = split(/\:/,$value); |
|
| } |
|
| if ($lasttime<$since) { next; } |
if ($lasttime<$since) { next; } |
| if ($description eq '.') { |
my $match = 1; |
| $qresult.=$key.'='.$descr.':'.$inst_code.'&'; |
unless ($description eq '.') { |
| } else { |
my $unescapeDescr = &unescape($descr); |
| my $unescapeVal = &unescape($descr); |
unless (eval('$unescapeDescr=~/\Q$description\E/i')) { |
| if (eval('$unescapeVal=~/\Q$description\E/i')) { |
$match = 0; |
| $qresult.=$key.'='.$descr.':'.$inst_code.'&'; |
|
| } |
} |
| |
} |
| |
unless ($instcodefilter eq '.' || !defined($instcodefilter)) { |
| |
my $unescapeInstcode = &unescape($inst_code); |
| |
unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) { |
| |
$match = 0; |
| |
} |
| } |
} |
| |
unless ($ownerfilter eq '.' || !defined($ownerfilter)) { |
| |
my $unescapeOwner = &unescape($owner); |
| |
unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
if ($match == 1) { |
| |
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
| |
} |
| } |
} |
| if (untie(%$hashref)) { |
if (untie(%$hashref)) { |
| chop($qresult); |
chop($qresult); |
|
Line 3792 sub get_institutional_code_format_handle
|
Line 3850 sub get_institutional_code_format_handle
|
| |
|
| return 1; |
return 1; |
| } |
} |
| |
®ister_handler("autoinstcodeformat", |
| |
\&get_institutional_code_format_handler,0,1,0); |
| |
|
| ®ister_handler("autoinstcodeformat", \&get_institutional_code_format_handler, |
# |
| 0,1,0); |
# Gets a student's photo to exist (in the correct image type) in the user's |
| |
# directory. |
| |
# Formal Parameters: |
| |
# $cmd - The command request that got us dispatched. |
| |
# $tail - A colon separated set of words that will be split into: |
| |
# $domain - student's domain |
| |
# $uname - student username |
| |
# $type - image type desired |
| |
# $client - The socket open on the client. |
| |
# Returns: |
| |
# 1 - continue processing. |
| |
sub student_photo_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
my ($domain,$uname,$type) = split(/:/, $tail); |
| |
|
| |
my $path=&propath($domain,$uname). |
| |
'/userfiles/internal/studentphoto.'.$type; |
| |
if (-e $path) { |
| |
&Reply($client,"ok\n","$cmd:$tail"); |
| |
return 1; |
| |
} |
| |
&mkpath($path); |
| |
my $file=&localstudentphoto::fetch($domain,$uname); |
| |
if (!$file) { |
| |
&Failure($client,"unavailable\n","$cmd:$tail"); |
| |
return 1; |
| |
} |
| |
if (!-e $path) { &convert_photo($file,$path); } |
| |
if (-e $path) { |
| |
&Reply($client,"ok\n","$cmd:$tail"); |
| |
return 1; |
| |
} |
| |
&Failure($client,"unable_to_convert\n","$cmd:$tail"); |
| |
return 1; |
| |
} |
| |
®ister_handler("studentphoto", \&student_photo_handler, 0, 1, 0); |
| |
|
| # mkpath makes all directories for a file, expects an absolute path with a |
# mkpath makes all directories for a file, expects an absolute path with a |
| # file or a trailing / if just a dir is passed |
# file or a trailing / if just a dir is passed |
|
Line 3804 sub mkpath {
|
Line 3899 sub mkpath {
|
| my @parts=split(/\//,$file,-1); |
my @parts=split(/\//,$file,-1); |
| my $now=$parts[0].'/'.$parts[1].'/'.$parts[2]; |
my $now=$parts[0].'/'.$parts[1].'/'.$parts[2]; |
| for (my $i=3;$i<= ($#parts-1);$i++) { |
for (my $i=3;$i<= ($#parts-1);$i++) { |
| $now.='/'.$parts[$i]; |
$now.='/'.$parts[$i]; |
| if (!-e $now) { |
if (!-e $now) { |
| if (!mkdir($now,0770)) { return 0; } |
if (!mkdir($now,0770)) { return 0; } |
| } |
} |
|
Line 3812 sub mkpath {
|
Line 3907 sub mkpath {
|
| return 1; |
return 1; |
| } |
} |
| |
|
| |
|
| #--------------------------------------------------------------- |
#--------------------------------------------------------------- |
| # |
# |
| # Getting, decoding and dispatching requests: |
# Getting, decoding and dispatching requests: |
|
Line 4185 sub ReadHostTable {
|
Line 4279 sub ReadHostTable {
|
| my $myloncapaname = $perlvar{'lonHostID'}; |
my $myloncapaname = $perlvar{'lonHostID'}; |
| Debug("My loncapa name is : $myloncapaname"); |
Debug("My loncapa name is : $myloncapaname"); |
| while (my $configline=<CONFIG>) { |
while (my $configline=<CONFIG>) { |
| if (!($configline =~ /^\s*\#/)) { |
if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) { |
| my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
| chomp($ip); $ip=~s/\D+$//; |
$name=~s/\s//g; |
| |
my $ip = gethostbyname($name); |
| |
if (length($ip) ne 4) { |
| |
&logthis("Skipping host $id name $name no IP $ip found\n"); |
| |
next; |
| |
} |
| |
$ip=inet_ntoa($ip); |
| $hostid{$ip}=$id; # LonCAPA name of host by IP. |
$hostid{$ip}=$id; # LonCAPA name of host by IP. |
| $hostdom{$id}=$domain; # LonCAPA domain name of host. |
$hostdom{$id}=$domain; # LonCAPA domain name of host. |
| $hostip{$id}=$ip; # IP address of host. |
$hostip{$id}=$ip; # IP address of host. |
| $hostdns{$name} = $id; # LonCAPA name of host by DNS. |
$hostdns{$name} = $id; # LonCAPA name of host by DNS. |
| |
|
| if ($id eq $perlvar{'lonHostID'}) { |
if ($id eq $perlvar{'lonHostID'}) { |
|
Line 4371 sub logstatus {
|
Line 4471 sub logstatus {
|
| flock(LOG,LOCK_EX); |
flock(LOG,LOCK_EX); |
| print LOG $$."\t".$clientname."\t".$currenthostid."\t" |
print LOG $$."\t".$clientname."\t".$currenthostid."\t" |
| .$status."\t".$lastlog."\t $keymode\n"; |
.$status."\t".$lastlog."\t $keymode\n"; |
| flock(DB,LOCK_UN); |
flock(LOG,LOCK_UN); |
| close(LOG); |
close(LOG); |
| } |
} |
| &status("Finished logging"); |
&status("Finished logging"); |
|
Line 4602 sub make_new_child {
|
Line 4702 sub make_new_child {
|
| if (defined($iaddr)) { |
if (defined($iaddr)) { |
| $clientip = inet_ntoa($iaddr); |
$clientip = inet_ntoa($iaddr); |
| Debug("Connected with $clientip"); |
Debug("Connected with $clientip"); |
| $clientdns = gethostbyaddr($iaddr, AF_INET); |
|
| Debug("Connected with $clientdns by name"); |
|
| } else { |
} else { |
| &logthis("Unable to determine clientip"); |
&logthis("Unable to determine clientip"); |
| $clientip='Unavailable'; |
$clientip='Unavailable'; |
|
Line 4643 sub make_new_child {
|
Line 4741 sub make_new_child {
|
| |
|
| ReadManagerTable; # May also be a manager!! |
ReadManagerTable; # May also be a manager!! |
| |
|
| my $clientrec=($hostid{$clientip} ne undef); |
my $outsideip=$clientip; |
| my $ismanager=($managers{$clientip} ne undef); |
if ($clientip eq '127.0.0.1') { |
| |
$outsideip=$hostip{$perlvar{'lonHostID'}}; |
| |
} |
| |
|
| |
my $clientrec=($hostid{$outsideip} ne undef); |
| |
my $ismanager=($managers{$outsideip} ne undef); |
| $clientname = "[unknonwn]"; |
$clientname = "[unknonwn]"; |
| if($clientrec) { # Establish client type. |
if($clientrec) { # Establish client type. |
| $ConnectionType = "client"; |
$ConnectionType = "client"; |
| $clientname = $hostid{$clientip}; |
$clientname = $hostid{$outsideip}; |
| if($ismanager) { |
if($ismanager) { |
| $ConnectionType = "both"; |
$ConnectionType = "both"; |
| } |
} |
| } else { |
} else { |
| $ConnectionType = "manager"; |
$ConnectionType = "manager"; |
| $clientname = $managers{$clientip}; |
$clientname = $managers{$outsideip}; |
| } |
} |
| my $clientok; |
my $clientok; |
| |
|
|
Line 5040 sub validate_user {
|
Line 5143 sub validate_user {
|
| my $krbserver = &Authen::Krb5::parse_name($krbservice); |
my $krbserver = &Authen::Krb5::parse_name($krbservice); |
| my $credentials= &Authen::Krb5::cc_default(); |
my $credentials= &Authen::Krb5::cc_default(); |
| $credentials->initialize($krbclient); |
$credentials->initialize($krbclient); |
| my $krbreturn = &Authen::KRb5::get_in_tkt_with_password($krbclient, |
my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient, |
| $krbserver, |
$krbserver, |
| $password, |
$password, |
| $credentials); |
$credentials); |
|
Line 5378 sub make_passwd_file {
|
Line 5481 sub make_passwd_file {
|
| return $result; |
return $result; |
| } |
} |
| |
|
| |
sub convert_photo { |
| |
my ($start,$dest)=@_; |
| |
system("convert $start $dest"); |
| |
} |
| |
|
| sub sethost { |
sub sethost { |
| my ($remotereq) = @_; |
my ($remotereq) = @_; |
| my (undef,$hostid)=split(/:/,$remotereq); |
my (undef,$hostid)=split(/:/,$remotereq); |
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom