|
version 1.266, 2004/11/27 17:23:08
|
version 1.291, 2005/07/12 21:29:58
|
|
Line 65 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 113 my %Dispatcher;
|
Line 112 my %Dispatcher;
|
| # |
# |
| my $lastpwderror = 13; # Largest error number from lcpasswd. |
my $lastpwderror = 13; # Largest error number from lcpasswd. |
| my @passwderrors = ("ok", |
my @passwderrors = ("ok", |
| "lcpasswd must be run as user 'www'", |
"pwchange_failure - lcpasswd must be run as user 'www'", |
| "lcpasswd got incorrect number of arguments", |
"pwchange_failure - lcpasswd got incorrect number of arguments", |
| "lcpasswd did not get the right nubmer of input text lines", |
"pwchange_failure - lcpasswd did not get the right nubmer of input text lines", |
| "lcpasswd too many simultaneous pwd changes in progress", |
"pwchange_failure - lcpasswd too many simultaneous pwd changes in progress", |
| "lcpasswd User does not exist.", |
"pwchange_failure - lcpasswd User does not exist.", |
| "lcpasswd Incorrect current passwd", |
"pwchange_failure - lcpasswd Incorrect current passwd", |
| "lcpasswd Unable to su to root.", |
"pwchange_failure - lcpasswd Unable to su to root.", |
| "lcpasswd Cannot set new passwd.", |
"pwchange_failure - lcpasswd Cannot set new passwd.", |
| "lcpasswd Username has invalid characters", |
"pwchange_failure - lcpasswd Username has invalid characters", |
| "lcpasswd Invalid characters in password", |
"pwchange_failure - lcpasswd Invalid characters in password", |
| "lcpasswd User already exists", |
"pwchange_failure - lcpasswd User already exists", |
| "lcpasswd Something went wrong with user addition.", |
"pwchange_failure - lcpasswd Something went wrong with user addition.", |
| "lcpasswd Password mismatch", |
"pwchange_failure - lcpasswd Password mismatch", |
| "lcpasswd Error filename is invalid"); |
"pwchange_failure - lcpasswd Error filename is invalid"); |
| |
|
| |
|
| # The array below are lcuseradd error strings.: |
# The array below are lcuseradd error strings.: |
|
Line 178 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 187 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 474 sub CopyFile {
|
Line 472 sub CopyFile {
|
| |
|
| my ($oldfile, $newfile) = @_; |
my ($oldfile, $newfile) = @_; |
| |
|
| # The file must exist: |
if (! copy($oldfile,$newfile)) { |
| |
return 0; |
| if(-e $oldfile) { |
|
| |
|
| # Read the old file. |
|
| |
|
| my $oldfh = IO::File->new("< $oldfile"); |
|
| if(!$oldfh) { |
|
| return 0; |
|
| } |
|
| my @contents = <$oldfh>; # Suck in the entire file. |
|
| |
|
| # write the backup file: |
|
| |
|
| my $newfh = IO::File->new("> $newfile"); |
|
| if(!(defined $newfh)){ |
|
| return 0; |
|
| } |
|
| my $lines = scalar @contents; |
|
| for (my $i =0; $i < $lines; $i++) { |
|
| print $newfh ($contents[$i]); |
|
| } |
|
| |
|
| $oldfh->close; |
|
| $newfh->close; |
|
| |
|
| chmod(0660, $newfile); |
|
| |
|
| return 1; |
|
| |
|
| } else { |
|
| return 0; |
|
| } |
} |
| |
chmod(0660, $newfile); |
| |
return 1; |
| } |
} |
| # |
# |
| # Host files are passed out with externally visible host IPs. |
# Host files are passed out with externally visible host IPs. |
|
Line 1312 sub user_authorization_type {
|
Line 1282 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 1395 sub du_handler {
|
Line 1367 sub du_handler {
|
| # assurance double sure, |
# assurance double sure, |
| # use execute_command to ensure that the command is not executed in |
# use execute_command to ensure that the command is not executed in |
| # a shell that can screw us up. |
# a shell that can screw us up. |
| |
my $file_list = execute_command("find $ududir -not -regex '.*\.[0-9]+\.[^\.]+' -not -name '*.meta' -print"); |
| my $duout = execute_command("du -ks $ududir"); |
my $duout = execute_command("du -ks $file_list"); |
| $duout=~s/[^\d]//g; #preserve only the numbers |
$duout=~s/[^\d]//g; #preserve only the numbers |
| &Reply($client,"$duout\n","$cmd:$ududir"); |
&Reply($client,"$duout\n","$cmd:$ududir"); |
| } else { |
} else { |
|
Line 1409 sub du_handler {
|
Line 1381 sub du_handler {
|
| ®ister_handler("du", \&du_handler, 0, 1, 0); |
®ister_handler("du", \&du_handler, 0, 1, 0); |
| |
|
| # |
# |
| |
# The ls_handler routine should be considered obosolete and is retained |
| |
# for communication with legacy servers. Please see the ls2_handler. |
| |
# |
| # ls - list the contents of a directory. For each file in the |
# ls - list the contents of a directory. For each file in the |
| # selected directory the filename followed by the full output of |
# selected directory the filename followed by the full output of |
| # the stat function is returned. The returned info for each |
# the stat function is returned. The returned info for each |
|
Line 1425 sub du_handler {
|
Line 1400 sub du_handler {
|
| # The reply is written to $client. |
# The reply is written to $client. |
| # |
# |
| sub ls_handler { |
sub ls_handler { |
| |
# obsoleted by ls2_handler |
| my ($cmd, $ulsdir, $client) = @_; |
my ($cmd, $ulsdir, $client) = @_; |
| |
|
| my $userinput = "$cmd:$ulsdir"; |
my $userinput = "$cmd:$ulsdir"; |
|
Line 1437 sub ls_handler {
|
Line 1413 sub ls_handler {
|
| if(-d $ulsdir) { |
if(-d $ulsdir) { |
| if (opendir(LSDIR,$ulsdir)) { |
if (opendir(LSDIR,$ulsdir)) { |
| while ($ulsfn=readdir(LSDIR)) { |
while ($ulsfn=readdir(LSDIR)) { |
| undef $obs, $rights; |
undef($obs); |
| |
undef($rights); |
| my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
| #We do some obsolete checking here |
#We do some obsolete checking here |
| if(-e $ulsdir.'/'.$ulsfn.".meta") { |
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
|
Line 1471 sub ls_handler {
|
Line 1448 sub ls_handler {
|
| } |
} |
| ®ister_handler("ls", \&ls_handler, 0, 1, 0); |
®ister_handler("ls", \&ls_handler, 0, 1, 0); |
| |
|
| |
# |
| |
# Please also see the ls_handler, which this routine obosolets. |
| |
# ls2_handler differs from ls_handler in that it escapes its return |
| |
# values before concatenating them together with ':'s. |
| |
# |
| |
# ls2 - list the contents of a directory. For each file in the |
| |
# selected directory the filename followed by the full output of |
| |
# the stat function is returned. The returned info for each |
| |
# file are separated by ':'. The stat fields are separated by &'s. |
| |
# Parameters: |
| |
# $cmd - The command that dispatched us (ls). |
| |
# $ulsdir - The directory path to list... I'm not sure what this |
| |
# is relative as things like ls:. return e.g. |
| |
# no_such_dir. |
| |
# $client - Socket open on the client. |
| |
# Returns: |
| |
# 1 - indicating that the daemon should not disconnect. |
| |
# Side Effects: |
| |
# The reply is written to $client. |
| |
# |
| |
sub ls2_handler { |
| |
my ($cmd, $ulsdir, $client) = @_; |
| |
|
| |
my $userinput = "$cmd:$ulsdir"; |
| |
|
| |
my $obs; |
| |
my $rights; |
| |
my $ulsout=''; |
| |
my $ulsfn; |
| |
if (-e $ulsdir) { |
| |
if(-d $ulsdir) { |
| |
if (opendir(LSDIR,$ulsdir)) { |
| |
while ($ulsfn=readdir(LSDIR)) { |
| |
undef($obs); |
| |
undef($rights); |
| |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
| |
#We do some obsolete checking here |
| |
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
| |
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
| |
my @obsolete=<FILE>; |
| |
foreach my $obsolete (@obsolete) { |
| |
if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } |
| |
if($obsolete =~ m|(<copyright>)(default)|) { |
| |
$rights = 1; |
| |
} |
| |
} |
| |
} |
| |
my $tmp = $ulsfn.'&'.join('&',@ulsstats); |
| |
if ($obs eq '1') { $tmp.="&1"; } else { $tmp.="&0"; } |
| |
if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; } |
| |
$ulsout.= &escape($tmp).':'; |
| |
} |
| |
closedir(LSDIR); |
| |
} |
| |
} else { |
| |
my @ulsstats=stat($ulsdir); |
| |
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; |
| |
} |
| |
} else { |
| |
$ulsout='no_such_dir'; |
| |
} |
| |
if ($ulsout eq '') { $ulsout='empty'; } |
| |
&Reply($client, "$ulsout\n", $userinput); # This supports debug logging. |
| |
return 1; |
| |
} |
| |
®ister_handler("ls2", \&ls2_handler, 0, 1, 0); |
| |
|
| # Process a reinit request. Reinit requests that either |
# Process a reinit request. Reinit requests that either |
| # lonc or lond be reinitialized so that an updated |
# lonc or lond be reinitialized so that an updated |
| # host.tab or domain.tab can be processed. |
# host.tab or domain.tab can be processed. |
|
Line 1659 sub change_password_handler {
|
Line 1703 sub change_password_handler {
|
| &Failure( $client, "non_authorized\n",$userinput); |
&Failure( $client, "non_authorized\n",$userinput); |
| } |
} |
| } elsif ($howpwd eq 'unix') { |
} elsif ($howpwd eq 'unix') { |
| # Unix means we have to access /etc/password |
my $result = &change_unix_password($uname, $npass); |
| &Debug("auth is unix"); |
|
| my $execdir=$perlvar{'lonDaemons'}; |
|
| &Debug("Opening lcpasswd pipeline"); |
|
| my $pf = IO::File->new("|$execdir/lcpasswd > " |
|
| ."$perlvar{'lonDaemons'}" |
|
| ."/logs/lcpasswd.log"); |
|
| print $pf "$uname\n$npass\n$npass\n"; |
|
| close $pf; |
|
| my $err = $?; |
|
| my $result = ($err>0 ? 'pwchange_failure' : 'ok'); |
|
| &logthis("Result of password change for $uname: ". |
&logthis("Result of password change for $uname: ". |
| &lcpasswdstrerror($?)); |
$result); |
| &Reply($client, "$result\n", $userinput); |
&Reply($client, "$result\n", $userinput); |
| } else { |
} else { |
| # this just means that the current password mode is not |
# this just means that the current password mode is not |
|
Line 1770 sub add_user_handler {
|
Line 1804 sub add_user_handler {
|
| # Implicit inputs: |
# Implicit inputs: |
| # The authentication systems describe above have their own forms of implicit |
# The authentication systems describe above have their own forms of implicit |
| # input into the authentication process that are described above. |
# input into the authentication process that are described above. |
| |
# NOTE: |
| |
# This is also used to change the authentication credential values (e.g. passwd). |
| |
# |
| # |
# |
| sub change_authentication_handler { |
sub change_authentication_handler { |
| |
|
|
Line 1789 sub change_authentication_handler {
|
Line 1826 sub change_authentication_handler {
|
| my $oldauth = &get_auth_type($udom, $uname); # Get old auth info. |
my $oldauth = &get_auth_type($udom, $uname); # Get old auth info. |
| my $passfilename = &password_path($udom, $uname); |
my $passfilename = &password_path($udom, $uname); |
| if ($passfilename) { # Not allowed to create a new user!! |
if ($passfilename) { # Not allowed to create a new user!! |
| my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); |
# If just changing the unix passwd. need to arrange to run |
| # |
# passwd since otherwise make_passwd_file will run |
| # If the current auth mode is internal, and the old auth mode was |
# lcuseradd which fails if an account already exists |
| # unix, or krb*, and the user is an author for this domain, |
# (to prevent an unscrupulous LONCAPA admin from stealing |
| # re-run manage_permissions for that role in order to be able |
# an existing account by overwriting it as a LonCAPA account). |
| # to take ownership of the construction space back to www:www |
|
| # |
if(($oldauth =~/^unix/) && ($umode eq "unix")) { |
| |
my $result = &change_unix_password($uname, $npass); |
| if( ($oldauth =~ /^unix/) && ($umode eq "internal")) { # unix -> internal |
&logthis("Result of password change for $uname: ".$result); |
| if(&is_author($udom, $uname)) { |
if ($result eq "ok") { |
| &Debug(" Need to manage author permissions..."); |
&Reply($client, "$result\n") |
| &manage_permissions("/$udom/_au", $udom, $uname, "internal:"); |
} else { |
| |
&Failure($client, "$result\n"); |
| } |
} |
| |
} else { |
| |
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); |
| |
# |
| |
# If the current auth mode is internal, and the old auth mode was |
| |
# unix, or krb*, and the user is an author for this domain, |
| |
# re-run manage_permissions for that role in order to be able |
| |
# to take ownership of the construction space back to www:www |
| |
# |
| |
|
| |
|
| |
if( (($oldauth =~ /^unix/) && ($umode eq "internal")) || |
| |
(($oldauth =~ /^internal/) && ($umode eq "unix")) ) { |
| |
if(&is_author($udom, $uname)) { |
| |
&Debug(" Need to manage author permissions..."); |
| |
&manage_permissions("/$udom/_au", $udom, $uname, "$umode:"); |
| |
} |
| |
} |
| |
&Reply($client, $result, $userinput); |
| } |
} |
| |
|
| |
|
| &Reply($client, $result, $userinput); |
|
| } else { |
} else { |
| &Failure($client, "non_authorized\n", $userinput); # Fail the user now. |
&Failure($client, "non_authorized\n", $userinput); # Fail the user now. |
| } |
} |
|
Line 1960 sub fetch_user_file_handler {
|
Line 2015 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 2317 sub put_user_profile_entry {
|
Line 2372 sub put_user_profile_entry {
|
| } |
} |
| ®ister_handler("put", \&put_user_profile_entry, 0, 1, 0); |
®ister_handler("put", \&put_user_profile_entry, 0, 1, 0); |
| |
|
| |
# Put a piece of new data in hash, returns error if entry already exists |
| |
# Parameters: |
| |
# $cmd - The command that got us here. |
| |
# $tail - Tail of the command (remaining parameters). |
| |
# $client - File descriptor connected to client. |
| |
# Returns |
| |
# 0 - Requested to exit, caller should shut down. |
| |
# 1 - Continue processing. |
| |
# |
| |
sub newput_user_profile_entry { |
| |
my ($cmd, $tail, $client) = @_; |
| |
|
| |
my $userinput = "$cmd:$tail"; |
| |
|
| |
my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4); |
| |
if ($namespace eq 'roles') { |
| |
&Failure( $client, "refused\n", $userinput); |
| |
return 1; |
| |
} |
| |
|
| |
chomp($what); |
| |
|
| |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
| |
&GDBM_WRCREAT(),"N",$what); |
| |
if(!$hashref) { |
| |
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ". |
| |
"while attempting put\n", $userinput); |
| |
return 1; |
| |
} |
| |
|
| |
my @pairs=split(/\&/,$what); |
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value)=split(/=/,$pair); |
| |
if (exists($hashref->{$key})) { |
| |
&Failure($client, "key_exists: ".$key."\n",$userinput); |
| |
return 1; |
| |
} |
| |
} |
| |
|
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value)=split(/=/,$pair); |
| |
$hashref->{$key}=$value; |
| |
} |
| |
|
| |
if (untie(%$hashref)) { |
| |
&Reply( $client, "ok\n", $userinput); |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." untie(GDBM) failed ". |
| |
"while attempting put\n", |
| |
$userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
®ister_handler("newput", \&newput_user_profile_entry, 0, 1, 0); |
| |
|
| # |
# |
| # Increment a profile entry in the user history file. |
# Increment a profile entry in the user history file. |
| # The history contains keyword value pairs. In this case, |
# The history contains keyword value pairs. In this case, |
|
Line 2347 sub increment_user_value_handler {
|
Line 2457 sub increment_user_value_handler {
|
| my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
| foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
| my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
| |
$value = &unescape($value); |
| # We could check that we have a number... |
# We could check that we have a number... |
| if (! defined($value) || $value eq '') { |
if (! defined($value) || $value eq '') { |
| $value = 1; |
$value = 1; |
| } |
} |
| $hashref->{$key}+=$value; |
$hashref->{$key}+=$value; |
| |
if ($namespace eq 'nohist_resourcetracker') { |
| |
if ($hashref->{$key} < 0) { |
| |
$hashref->{$key} = 0; |
| |
} |
| |
} |
| } |
} |
| if (untie(%$hashref)) { |
if (untie(%$hashref)) { |
| &Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
|
Line 2835 sub store_handler {
|
Line 2951 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 3106 sub reply_query_handler {
|
Line 3222 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 3127 sub put_course_id_handler {
|
Line 3251 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,$courseinfo) = split(/=/,$pair); |
my ($key,$courseinfo) = split(/=/,$pair,2); |
| |
$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; |
$hashref->{$key}=$courseinfo.':'.$now; |
| } |
} |
| if (untie(%$hashref)) { |
if (untie(%$hashref)) { |
|
Line 3166 sub put_course_id_handler {
|
Line 3306 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 3176 sub dump_course_id_handler {
|
Line 3325 sub dump_course_id_handler {
|
| |
|
| my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
| |
|
| my ($udom,$since,$description,$instcodefilter,$ownerfilter) =split(/:/,$tail); |
my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail); |
| if (defined($description)) { |
if (defined($description)) { |
| $description=&unescape($description); |
$description=&unescape($description); |
| } else { |
} else { |
|
Line 3192 sub dump_course_id_handler {
|
Line 3341 sub dump_course_id_handler {
|
| } else { |
} else { |
| $ownerfilter='.'; |
$ownerfilter='.'; |
| } |
} |
| |
if (defined($coursefilter)) { |
| |
$coursefilter=&unescape($coursefilter); |
| |
} else { |
| |
$coursefilter='.'; |
| |
} |
| |
|
| unless (defined($since)) { $since=0; } |
unless (defined($since)) { $since=0; } |
| my $qresult=''; |
my $qresult=''; |
|
Line 3199 sub dump_course_id_handler {
|
Line 3353 sub dump_course_id_handler {
|
| if ($hashref) { |
if ($hashref) { |
| while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
| my ($descr,$lasttime,$inst_code,$owner); |
my ($descr,$lasttime,$inst_code,$owner); |
| if ($value =~ m/^([^\:]*):([^\:]*):([^\:]*):(\d+)$/) { |
my @courseitems = split(/:/,$value); |
| ($descr,$inst_code,$owner,$lasttime)=($1,$2,$3,$4); |
$lasttime = pop(@courseitems); |
| } elsif ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { |
($descr,$inst_code,$owner)=@courseitems; |
| ($descr,$inst_code,$lasttime)=($1,$2,$3); |
|
| } else { |
|
| ($descr,$lasttime) = split(/\:/,$value); |
|
| } |
|
| if ($lasttime<$since) { next; } |
if ($lasttime<$since) { next; } |
| my $match = 1; |
my $match = 1; |
| unless ($description eq '.') { |
unless ($description eq '.') { |
|
Line 3226 sub dump_course_id_handler {
|
Line 3376 sub dump_course_id_handler {
|
| $match = 0; |
$match = 0; |
| } |
} |
| } |
} |
| |
unless ($coursefilter eq '.' || !defined($coursefilter)) { |
| |
my $unescapeCourse = &unescape($key); |
| |
unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) { |
| |
$match = 0; |
| |
} |
| |
} |
| if ($match == 1) { |
if ($match == 1) { |
| $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
| } |
} |
|
Line 4249 sub ReadHostTable {
|
Line 4405 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 4391 sub Reply {
|
Line 4553 sub Reply {
|
| Debug("Request was $request Reply was $reply"); |
Debug("Request was $request Reply was $reply"); |
| |
|
| $Transactions++; |
$Transactions++; |
| |
|
| |
|
| } |
} |
| |
|
| |
|
|
Line 4435 sub logstatus {
|
Line 4595 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 4620 $SIG{USR2} = \&UpdateHosts;
|
Line 4780 $SIG{USR2} = \&UpdateHosts;
|
| |
|
| ReadHostTable; |
ReadHostTable; |
| |
|
| |
my $dist=`$perlvar{'lonDaemons'}/distprobe`; |
| |
|
| # -------------------------------------------------------------- |
# -------------------------------------------------------------- |
| # Accept connections. When a connection comes in, it is validated |
# Accept connections. When a connection comes in, it is validated |
| # and if good, a child process is created to process transactions |
# and if good, a child process is created to process transactions |
|
Line 4666 sub make_new_child {
|
Line 4828 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 4697 sub make_new_child {
|
Line 4857 sub make_new_child {
|
| # my $tmpsnum=0; # Now global |
# my $tmpsnum=0; # Now global |
| #---------------------------------------------------- kerberos 5 initialization |
#---------------------------------------------------- kerberos 5 initialization |
| &Authen::Krb5::init_context(); |
&Authen::Krb5::init_context(); |
| &Authen::Krb5::init_ets(); |
if ($dist ne 'fedora4') { |
| |
&Authen::Krb5::init_ets(); |
| |
} |
| |
|
| &status('Accepted connection'); |
&status('Accepted connection'); |
| # ============================================================================= |
# ============================================================================= |
|
Line 4707 sub make_new_child {
|
Line 4869 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 4902 sub is_author {
|
Line 5069 sub is_author {
|
| # user - Name of the user for which the role is being put. |
# user - Name of the user for which the role is being put. |
| # authtype - The authentication type associated with the user. |
# authtype - The authentication type associated with the user. |
| # |
# |
| sub manage_permissions |
sub manage_permissions { |
| { |
|
| |
|
| |
|
| my ($request, $domain, $user, $authtype) = @_; |
my ($request, $domain, $user, $authtype) = @_; |
| |
|
| &Debug("manage_permissions: $request $domain $user $authtype"); |
&Debug("manage_permissions: $request $domain $user $authtype"); |
| |
|
| # See if the request is of the form /$domain/_au |
# See if the request is of the form /$domain/_au |
| if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... |
if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput... |
| my $execdir = $perlvar{'lonDaemons'}; |
my $execdir = $perlvar{'lonDaemons'}; |
| my $userhome= "/home/$user" ; |
my $userhome= "/home/$user" ; |
| &logthis("system $execdir/lchtmldir $userhome $user $authtype"); |
&logthis("system $execdir/lchtmldir $userhome $user $authtype"); |
|
Line 5104 sub validate_user {
|
Line 5268 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 5348 sub subscribe {
|
Line 5512 sub subscribe {
|
| } |
} |
| return $result; |
return $result; |
| } |
} |
| |
# Change the passwd of a unix user. The caller must have |
| |
# first verified that the user is a loncapa user. |
| |
# |
| |
# Parameters: |
| |
# user - Unix user name to change. |
| |
# pass - New password for the user. |
| |
# Returns: |
| |
# ok - if success |
| |
# other - Some meaningfule error message string. |
| |
# NOTE: |
| |
# invokes a setuid script to change the passwd. |
| |
sub change_unix_password { |
| |
my ($user, $pass) = @_; |
| |
|
| |
&Debug("change_unix_password"); |
| |
my $execdir=$perlvar{'lonDaemons'}; |
| |
&Debug("Opening lcpasswd pipeline"); |
| |
my $pf = IO::File->new("|$execdir/lcpasswd > " |
| |
."$perlvar{'lonDaemons'}" |
| |
."/logs/lcpasswd.log"); |
| |
print $pf "$user\n$pass\n$pass\n"; |
| |
close $pf; |
| |
my $err = $?; |
| |
return ($err < @passwderrors) ? $passwderrors[$err] : |
| |
"pwchange_falure - unknown error"; |
| |
|
| |
|
| |
} |
| |
|
| |
|
| sub make_passwd_file { |
sub make_passwd_file { |
| my ($uname, $umode,$npass,$passfilename)=@_; |
my ($uname, $umode,$npass,$passfilename)=@_; |
|
Line 5407 sub make_passwd_file {
|
Line 5600 sub make_passwd_file {
|
| print $se "$npass\n"; |
print $se "$npass\n"; |
| print $se "$lc_error_file\n"; # Status -> unique file. |
print $se "$lc_error_file\n"; # Status -> unique file. |
| } |
} |
| my $error = IO::File->new("< $lc_error_file"); |
if (-r $lc_error_file) { |
| my $useraddok = <$error>; |
&Debug("Opening error file: $lc_error_file"); |
| $error->close; |
my $error = IO::File->new("< $lc_error_file"); |
| unlink($lc_error_file); |
my $useraddok = <$error>; |
| |
$error->close; |
| chomp $useraddok; |
unlink($lc_error_file); |
| |
|
| if($useraddok > 0) { |
chomp $useraddok; |
| my $error_text = &lcuseraddstrerror($useraddok); |
|
| &logthis("Failed lcuseradd: $error_text"); |
if($useraddok > 0) { |
| $result = "lcuseradd_failed:$error_text\n"; |
my $error_text = &lcuseraddstrerror($useraddok); |
| } else { |
&logthis("Failed lcuseradd: $error_text"); |
| my $pf = IO::File->new(">$passfilename"); |
$result = "lcuseradd_failed:$error_text\n"; |
| if($pf) { |
} else { |
| print $pf "unix:\n"; |
my $pf = IO::File->new(">$passfilename"); |
| } else { |
if($pf) { |
| $result = "pass_file_failed_error"; |
print $pf "unix:\n"; |
| |
} else { |
| |
$result = "pass_file_failed_error"; |
| |
} |
| } |
} |
| |
} else { |
| |
&Debug("Could not locate lcuseradd error: $lc_error_file"); |
| |
$result="bug_lcuseradd_no_output_file"; |
| } |
} |
| } |
} |
| } elsif ($umode eq 'none') { |
} elsif ($umode eq 'none') { |
![[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