version 1.205, 2004/07/03 18:49:42
|
version 1.208, 2004/07/23 13:36:29
|
Line 71 my $thisserver; # DNS of us.
|
Line 71 my $thisserver; # DNS of us.
|
|
|
my $keymode; |
my $keymode; |
|
|
|
my $cipher; # Cipher key negotiated with client |
|
my $tmpsnum = 0; # Id of tmpputs. |
|
|
# |
# |
# Connection type is: |
# Connection type is: |
# client - All client actions are allowed |
# client - All client actions are allowed |
Line 90 my %managers; # Ip -> manager names
|
Line 93 my %managers; # Ip -> manager names
|
my %perlvar; # Will have the apache conf defined perl vars. |
my %perlvar; # Will have the apache conf defined perl vars. |
|
|
# |
# |
|
# The hash below is used for command dispatching, and is therefore keyed on the request keyword. |
|
# Each element of the hash contains a reference to an array that contains: |
|
# A reference to a sub that executes the request corresponding to the keyword. |
|
# A flag that is true if the request must be encoded to be acceptable. |
|
# A mask with bits as follows: |
|
# CLIENT_OK - Set when the function is allowed by ordinary clients |
|
# MANAGER_OK - Set when the function is allowed to manager clients. |
|
# |
|
my $CLIENT_OK = 1; |
|
my $MANAGER_OK = 2; |
|
my %Dispatcher; |
|
|
|
|
|
# |
# The array below are password error strings." |
# The array below are password error strings." |
# |
# |
my $lastpwderror = 13; # Largest error number from lcpasswd. |
my $lastpwderror = 13; # Largest error number from lcpasswd. |
Line 127 my @adderrors = ("ok",
|
Line 144 my @adderrors = ("ok",
|
"lcuseradd Password mismatch"); |
"lcuseradd Password mismatch"); |
|
|
|
|
|
|
|
# |
|
# Statistics that are maintained and dislayed in the status line. |
|
# |
|
my $Transactions; # Number of attempted transactions. |
|
my $Failures; # Number of transcations failed. |
|
|
|
# ResetStatistics: |
|
# Resets the statistics counters: |
|
# |
|
sub ResetStatistics { |
|
$Transactions = 0; |
|
$Failures = 0; |
|
} |
|
|
|
|
|
|
#------------------------------------------------------------------------ |
#------------------------------------------------------------------------ |
# |
# |
# LocalConnection |
# LocalConnection |
Line 899 sub EditFile {
|
Line 933 sub EditFile {
|
|
|
return "ok\n"; |
return "ok\n"; |
} |
} |
|
|
|
#--------------------------------------------------------------- |
|
# |
|
# Manipulation of hash based databases (factoring out common code |
|
# for later use as we refactor. |
|
# |
|
# Ties a domain level resource file to a hash. |
|
# If requested a history entry is created in the associated hist file. |
|
# |
|
# Parameters: |
|
# domain - Name of the domain in which the resource file lives. |
|
# namespace - Name of the hash within that domain. |
|
# how - How to tie the hash (e.g. GDBM_WRCREAT()). |
|
# loghead - Optional parameter, if present a log entry is created |
|
# in the associated history file and this is the first part |
|
# of that entry. |
|
# logtail - Goes along with loghead, The actual logentry is of the |
|
# form $loghead:<timestamp>:logtail. |
|
# Returns: |
|
# Reference to a hash bound to the db file or alternatively undef |
|
# if the tie failed. |
|
# |
|
sub TieDomainHash { |
|
my ($domain, |
|
$namespace, |
|
$how) = @_; |
|
|
|
# Filter out any whitespace in the domain name: |
|
|
|
$domain =~ s/\W//g; |
|
|
|
# We have enough to go on to tie the hash: |
|
|
|
my $user_top_dir = $perlvar{'lonUsersDir'}; |
|
my $domain_dir = $user_top_dir."/$domain"; |
|
my $resource_file = $domain_dir."/$namespace.db"; |
|
my %hash; |
|
if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) { |
|
if (scalar @_) { # Need to log the operation. |
|
my $logFh = IO::File->new(">>domain_dir/$namespace.hist"); |
|
if($logFh) { |
|
my $timestamp = time; |
|
my ($loghead, $logtail) = @_; |
|
print $logFh "$loghead:$timestamp:$logtail\n"; |
|
} |
|
} |
|
return \%hash; # Return the tied hash. |
|
} |
|
else { |
|
return undef; # Tie failed. |
|
} |
|
} |
|
|
|
# |
|
# Ties a user's resource file to a hash. |
|
# If necessary, an appropriate history |
|
# log file entry is made as well. |
|
# This sub factors out common code from the subs that manipulate |
|
# the various gdbm files that keep keyword value pairs. |
|
# Parameters: |
|
# domain - Name of the domain the user is in. |
|
# user - Name of the 'current user'. |
|
# namespace - Namespace representing the file to tie. |
|
# how - What the tie is done to (e.g. GDBM_WRCREAT(). |
|
# loghead - Optional first part of log entry if there may be a |
|
# history file. |
|
# what - Optional tail of log entry if there may be a history |
|
# file. |
|
# Returns: |
|
# hash to which the database is tied. It's up to the caller to untie. |
|
# undef if the has could not be tied. |
|
# |
|
sub TieUserHash { |
|
my ($domain, |
|
$user, |
|
$namespace, |
|
$how) = @_; |
|
|
|
|
|
$namespace=~s/\//\_/g; # / -> _ |
|
$namespace=~s/\W//g; # whitespace eliminated. |
|
my $proname = propath($domain, $user); |
|
|
|
# If this is a namespace for which a history is kept, |
|
# make the history log entry: |
|
|
|
|
|
if (($namespace =~/^nohist\_/) && (scalar @_ > 0)) { |
|
my $args = scalar @_; |
|
Debug(" Opening history: $namespace $args"); |
|
my $hfh = IO::File->new(">>$proname/$namespace.hist"); |
|
if($hfh) { |
|
my $now = time; |
|
my $loghead = shift; |
|
my $what = shift; |
|
print $hfh "$loghead:$now:$what\n"; |
|
} |
|
} |
|
# Tie the database. |
|
|
|
my %hash; |
|
if(tie(%hash, 'GDBM_File', "$proname/$namespace.db", |
|
$how, 0640)) { |
|
return \%hash; |
|
} |
|
else { |
|
return undef; |
|
} |
|
|
|
} |
|
#--------------------------------------------------------------- |
|
# |
|
# Getting, decoding and dispatching requests: |
|
# |
|
|
|
# |
|
# Get a Request: |
|
# Gets a Request message from the client. The transaction |
|
# is defined as a 'line' of text. We remove the new line |
|
# from the text line. |
|
# |
|
sub GetRequest { |
|
my $input = <$client>; |
|
chomp($input); |
|
|
|
Debug("Request = $input\n"); |
|
|
|
&status('Processing '.$clientname.':'.$input); |
|
|
|
return $input; |
|
} |
|
# |
|
# Decipher encoded traffic |
|
# Parameters: |
|
# input - Encoded data. |
|
# Returns: |
|
# Decoded data or undef if encryption key was not yet negotiated. |
|
# Implicit input: |
|
# cipher - This global holds the negotiated encryption key. |
|
# |
|
sub Decipher { |
|
my ($input) = @_; |
|
my $output = ''; |
|
|
|
|
|
if($cipher) { |
|
my($enc, $enclength, $encinput) = split(/:/, $input); |
|
for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) { |
|
$output .= |
|
$cipher->decrypt(pack("H16", substr($encinput, $encidx, 16))); |
|
} |
|
return substr($output, 0, $enclength); |
|
} else { |
|
return undef; |
|
} |
|
} |
|
|
|
# |
|
# Register a command processor. This function is invoked to register a sub |
|
# to process a request. Once registered, the ProcessRequest sub can automatically |
|
# dispatch requests to an appropriate sub, and do the top level validity checking |
|
# as well: |
|
# - Is the keyword recognized. |
|
# - Is the proper client type attempting the request. |
|
# - Is the request encrypted if it has to be. |
|
# Parameters: |
|
# $request_name - Name of the request being registered. |
|
# This is the command request that will match |
|
# against the hash keywords to lookup the information |
|
# associated with the dispatch information. |
|
# $procedure - Reference to a sub to call to process the request. |
|
# All subs get called as follows: |
|
# Procedure($cmd, $tail, $replyfd, $key) |
|
# $cmd - the actual keyword that invoked us. |
|
# $tail - the tail of the request that invoked us. |
|
# $replyfd- File descriptor connected to the client |
|
# $must_encode - True if the request must be encoded to be good. |
|
# $client_ok - True if it's ok for a client to request this. |
|
# $manager_ok - True if it's ok for a manager to request this. |
|
# Side effects: |
|
# - On success, the Dispatcher hash has an entry added for the key $RequestName |
|
# - On failure, the program will die as it's a bad internal bug to try to |
|
# register a duplicate command handler. |
|
# |
|
sub RegisterHandler { |
|
my ($request_name, |
|
$procedure, |
|
$must_encode, |
|
$client_ok, |
|
$manager_ok) = @_; |
|
|
|
# Don't allow duplication# |
|
|
|
if (defined $Dispatcher{$request_name}) { |
|
die "Attempting to define a duplicate request handler for $request_name\n"; |
|
} |
|
# Build the client type mask: |
|
|
|
my $client_type_mask = 0; |
|
if($client_ok) { |
|
$client_type_mask |= $CLIENT_OK; |
|
} |
|
if($manager_ok) { |
|
$client_type_mask |= $MANAGER_OK; |
|
} |
|
|
|
# Enter the hash: |
|
|
|
my @entry = ($procedure, $must_encode, $client_type_mask); |
|
|
|
$Dispatcher{$request_name} = \@entry; |
|
|
|
|
|
} |
|
|
|
|
|
#------------------------------------------------------------------ |
|
|
|
|
|
|
|
|
# |
# |
# Convert an error return code from lcpasswd to a string value. |
# Convert an error return code from lcpasswd to a string value. |
# |
# |
Line 1425 while (1) {
|
Line 1680 while (1) {
|
|
|
sub make_new_child { |
sub make_new_child { |
my $pid; |
my $pid; |
my $cipher; |
# my $cipher; # Now global |
my $sigset; |
my $sigset; |
|
|
$client = shift; |
$client = shift; |
Line 1484 sub make_new_child {
|
Line 1739 sub make_new_child {
|
sigprocmask(SIG_UNBLOCK, $sigset) |
sigprocmask(SIG_UNBLOCK, $sigset) |
or die "Can't unblock SIGINT for fork: $!\n"; |
or die "Can't unblock SIGINT for fork: $!\n"; |
|
|
my $tmpsnum=0; |
# my $tmpsnum=0; # Now global |
#---------------------------------------------------- kerberos 5 initialization |
#---------------------------------------------------- kerberos 5 initialization |
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_ets(); |
&Authen::Krb5::init_ets(); |
Line 2233 sub make_new_child {
|
Line 2488 sub make_new_child {
|
} elsif ($userinput =~ /^put/) { |
} elsif ($userinput =~ /^put/) { |
if(isClient) { |
if(isClient) { |
my ($cmd,$udom,$uname,$namespace,$what) |
my ($cmd,$udom,$uname,$namespace,$what) |
=split(/:/,$userinput); |
=split(/:/,$userinput,5); |
$namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
if ($namespace ne 'roles') { |
if ($namespace ne 'roles') { |