--- loncom/lond 2003/10/08 14:30:09 1.153 +++ loncom/lond 2004/05/04 10:09:38 1.178.2.22 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.153 2003/10/08 14:30:09 www Exp $ +# $Id: lond,v 1.178.2.22 2004/05/04 10:09:38 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -10,7 +10,7 @@ # # LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or +# the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # LON-CAPA is distributed in the hope that it will be useful, @@ -20,102 +20,14 @@ # # You should have received a copy of the GNU General Public License # along with LON-CAPA; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # /home/httpd/html/adm/gpl.txt # + + # http://www.lon-capa.org/ # -# 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30, -# 7/8,7/9,7/10,7/12,7/17,7/19,9/21, -# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16, -# 12/7,12/15,01/06,01/11,01/12,01/14,2/8, -# 03/07,05/31 Gerd Kortemeyer -# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer -# 12/05,12/13,12/29 Gerd Kortemeyer -# YEAR=2001 -# 02/12 Gerd Kortemeyer -# 03/24 Gerd Kortemeyer -# 05/11,05/28,08/30 Gerd Kortemeyer -# 11/26,11/27 Gerd Kortemeyer -# 12/22 Gerd Kortemeyer -# YEAR=2002 -# 01/20/02,02/05 Gerd Kortemeyer -# 02/05 Guy Albertelli -# 02/12 Gerd Kortemeyer -# 02/19 Matthew Hall -# 02/25 Gerd Kortemeyer -# 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon -# logic simpler (and there were problems maintaining the preforked -# population). Since the time averaged connection rate is close to zero -# because lonc's purpose is to maintain near continuous connnections, -# preforking is not really needed. -# 08/xx/2003 Ron Fox: Add management requests. Management requests -# will be validated via a call to ValidateManager. At present, this -# is done by simple host verification. In the future we can modify -# this function to do a certificate check. -# Management functions supported include: -# - pushing /home/httpd/lonTabs/hosts.tab -# - pushing /home/httpd/lonTabs/domain.tab -# 09/08/2003 Ron Fox: Told lond to take care of change logging so we -# don't have to remember it: -# $Log: lond,v $ -# Revision 1.153 2003/10/08 14:30:09 www -# Minor typos. -# -# Revision 1.152 2003/10/08 14:18:34 www -# Not good: this should be backported into 1.0.2! -# -# Revision 1.151 2003/10/03 15:11:03 albertel -# - if we fail to fetch an update to the file, don't blow away the old one -# (this was the BUG that blew away that one default.sequence that Matthew -# ended up restoring from data.) -# -# Revision 1.150 2003/09/30 10:16:06 foxr -# Added invocation of apachereload in ReloadApache sub. -# This completes the addtion of the reinit functionality. -# -# Revision 1.149 2003/09/30 09:44:13 foxr -# Tested UpdateHosts ability to -# - Remove live children for hosts that are no longer in the hosts.tab -# - Remove live children for hosts whose IPs have changed in the hosts.tab -# -# Revision 1.148 2003/09/29 10:09:18 foxr -# Put in logic to reinit lond itself (except for apache reload). I don't believe -# this logic works correctly yet, however lond still does everything it used to doso I'll do the commit anyway. -# -# Revision 1.147 2003/09/23 11:23:31 foxr -# Comlplete implementation of reinit functionality. Must still implement -# the actual initialization functionality, but the process can now -# receive the request and either invoke the appropriate internal function or -# signal the correct lonc. -# -# Revision 1.146 2003/09/16 10:28:14 foxr -# ReinitProcess - decode the process selector and produce the associated pid -# filename. Note: While it is possible to test that valid process selectors are -# handled properly I am not able to test that invalid process selectors produce -# the appropriate error as lonManage also blocks the use of invalid process selectors. -# -# Revision 1.145 2003/09/16 10:13:20 foxr -# Added ReinitProcess function to oversee the parsing and processing of the -# reinit: client request. -# -# Revision 1.144 2003/09/16 09:47:01 foxr -# Added skeletal support for SIGUSR2 (update hosts.tab) -# -# Revision 1.143 2003/09/15 10:03:52 foxr -# Completed and tested code for pushfile. -# -# Revision 1.142 2003/09/09 20:47:46 www -# Permanently store chatroom entries in chatroom.log -# -# Revision 1.141 2003/09/08 10:32:07 foxr -# Added PushFile sub This sub oversees the push of a new configuration table file -# Currently supported files are: -# - hosts.tab (transaction pushfile:hosts:contents) -# - domain.tab (transaction pushfile:domain:contents) -# - use strict; use lib '/home/httpd/lib/perl/'; @@ -134,29 +46,59 @@ use Authen::Krb5; use lib '/home/httpd/lib/perl/'; use localauth; use File::Copy; +use LONCAPA::ConfigFileEdit; -my $DEBUG = 0; # Non zero to enable debug log entries. +my $DEBUG = 1; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.153 $'; #' stupid emacs +my $VERSION='$Revision: 1.178.2.22 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; my $client; my $clientip; +my $clientname; + +my $cipher; # Cipher key negotiated with client. +my $tmpsnum = 0;; # Id of tmpputs. my $server; my $thisserver; +# +# Connection type is: +# client - All client actions are allowed +# manager - only management functions allowed. +# both - Both management and client actions are allowed +# + +my $ConnectionType; + my %hostid; my %hostdom; my %hostip; + +my %managers; # Ip -> manager names + 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." # my $lastpwderror = 13; # Largest error number from lcpasswd. @@ -193,6 +135,2632 @@ my @adderrors = ("ok", "lcuseradd Could not add user.", "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; +} + +# +# Return true if client is a manager. +# +sub isManager { + return (($ConnectionType eq "manager") || ($ConnectionType eq "both")); +} +# +# Return tru if client can do client functions +# +sub isClient { + return (($ConnectionType eq "client") || ($ConnectionType eq "both")); +} +# +# 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::logtail. +# Returns: +# Reference to a hash bound to the db file or alternatively undef +# if the tie failed. +# +sub TieDomainHash { + my $domain = shift; + my $namespace = shift; + my $how = shift; + + # Filter out any whitespace in the domain name: + + $domain =~ s/\W//g; + + # We have enough to go on to tie the hash: + + my $UserTopDir = $perlvar{'lonUsersDir'}; + my $DomainDir = $UserTopDir."/$domain"; + my $ResourceFile = $DomainDir."/$namespace.db"; + my %hash; + if(tie(%hash, 'GDBM_File', $ResourceFile, $how, 0640)) { + if (scalar @_) { # Need to log the operation. + my $logFh = IO::File->new(">>$DomainDir/$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 = shift; + my $user = shift; + my $namespace = shift; + my $how = shift; + + $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; + } + +} + +# +# 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 = shift; + 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: +# $RequestName - 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 +# $MustEncode - True if the request must be encoded to be good. +# $ClientOk - True if it's ok for a client to request this. +# $ManagerOk - 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 $RequestName = shift; + my $Procedure = shift; + my $MustEncode = shift; + my $ClientOk = shift; + my $ManagerOk = shift; + + # Don't allow duplication# + + if (defined $Dispatcher{$RequestName}) { + die "Attempting to define a duplicate request handler for $RequestName\n"; + } + # Build the client type mask: + + my $ClientTypeMask = 0; + if($ClientOk) { + $ClientTypeMask |= $CLIENT_OK; + } + if($ManagerOk) { + $ClientTypeMask |= $MANAGER_OK; + } + + # Enter the hash: + + my @entry = ($Procedure, $MustEncode, $ClientTypeMask); + + $Dispatcher{$RequestName} = \@entry; + + +} + +#--------------------- Request Handlers -------------------------------------------- +# +# By convention each request handler registers itself prior to the sub declaration: +# + +# Handles ping requests. +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $replyfd- File descriptor connected to the client +# Implicit Inputs: +# $currenthostid - Global variable that carries the name of the host we are +# known as. +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit. +# Side effects: +# Reply information is sent to the client. + +sub PingHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + Reply( $client,"$currenthostid\n","$cmd:$tail"); + + return 1; +} +RegisterHandler("ping", \&PingHandler, 0, 1, 1); # Ping unencoded, client or manager. +# +# Handles pong reequests: +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $replyfd- File descriptor connected to the client +# Implicit Inputs: +# $currenthostid - Global variable that carries the name of the host we are +# connected to. +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit. +# Side effects: +# Reply information is sent to the client. + +sub PongHandler { + my $cmd = shift; + my $tail = shift; + my $replyfd = shift; + + my $reply=&reply("ping",$clientname); + Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); + return 1; +} +RegisterHandler("pong", \&PongHandler, 0, 1, 1); # Pong unencoded, client or manager + +# +# EstablishKeyHandler: +# Called to establish an encrypted session key with the remote client. +# +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $replyfd- File descriptor connected to the client +# Implicit Inputs: +# $currenthostid - Global variable that carries the name of the host +# known as. +# $clientname - Global variable that carries the name of the hsot we're connected to. +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit. +# Implicit Outputs: +# Reply information is sent to the client. +# $cipher is set with a reference to a new IDEA encryption object. +# +sub EstablishKeyHandler { + my $cmd = shift; + my $tail = shift; + my $replyfd = shift; + + my $buildkey=time.$$.int(rand 100000); + $buildkey=~tr/1-6/A-F/; + $buildkey=int(rand 100000).$buildkey.int(rand 100000); + my $key=$currenthostid.$clientname; + $key=~tr/a-z/A-Z/; + $key=~tr/G-P/0-9/; + $key=~tr/Q-Z/0-9/; + $key=$key.$buildkey.$key.$buildkey.$key.$buildkey; + $key=substr($key,0,32); + my $cipherkey=pack("H32",$key); + $cipher=new IDEA $cipherkey; + Reply($replyfd, "$buildkey\n", "$cmd:$tail"); + + return 1; + +} +RegisterHandler("ekey", \&EstablishKeyHandler, 0, 1,1); + +# LoadHandler: +# Handler for the load command. Returns the current system load average +# to the requestor. +# +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $replyfd- File descriptor connected to the client +# Implicit Inputs: +# $currenthostid - Global variable that carries the name of the host +# known as. +# $clientname - Global variable that carries the name of the hsot we're connected to. +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit. +# Side effects: +# Reply information is sent to the client. +sub LoadHandler { + my $cmd = shift; + my $tail = shift; + my $replyfd = shift; + + # Get the load average from /proc/loadavg and calculate it as a percentage of + # the allowed load limit as set by the perl global variable lonLoadLim + + my $loadavg; + my $loadfile=IO::File->new('/proc/loadavg'); + + $loadavg=<$loadfile>; + $loadavg =~ s/\s.*//g; # Extract the first field only. + + my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; + + Reply( $replyfd, "$loadpercent\n", "$cmd:$tail"); + + return 1; +} +RegisterHandler("load", \&LoadHandler, 0, 1, 0); + + +# +# Process the userload request. This sub returns to the client the current +# user load average. It can be invoked either by clients or managers. +# +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $replyfd- File descriptor connected to the client +# Implicit Inputs: +# $currenthostid - Global variable that carries the name of the host +# known as. +# $clientname - Global variable that carries the name of the hsot we're connected to. +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit +# Implicit inputs: +# whatever the userload() function requires. +# Implicit outputs: +# the reply is written to the client. +# +sub UserLoadHandler { + my $cmd = shift; + my $tail = shift; + my $replyfd = shift; + + my $userloadpercent=&userload(); + Reply($replyfd, "$userloadpercent\n", "$cmd:$tail"); + + return 1; +} +RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0); + +# Process a request for the authorization type of a user: +# (userauth). +# +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $replyfd- File descriptor connected to the client +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit +# Implicit outputs: +# The user authorization type is written to the client. +# +sub UserAuthorizationType { + my $cmd = shift; + my $tail = shift; + my $replyfd = shift; + + my $userinput = "$cmd:$tail"; + + # Pull the domain and username out of the command tail. + # and call GetAuthType to determine the authentication type. + + my ($udom,$uname)=split(/:/,$tail); + my $result = GetAuthType($udom, $uname); + if($result eq "nouser") { + Failure( $replyfd, "unknown_user\n", $userinput); + } else { + # + # We only want to pass the second field from GetAuthType + # for ^krb.. otherwise we'll be handing out the encrypted + # password for internals e.g. + # + my ($type,$otherinfo) = split(/:/,$result); + if($type =~ /^krb/) { + $type = $result; + } + Reply( $replyfd, "$type\n", $userinput); + } + + return 1; +} +RegisterHandler("currentauth", \&UserAuthorizationType, 1, 1, 0); +# +# Process a request by a manager to push a hosts or domain table +# to us. We pick apart the command and pass it on to the subs +# that already exist to do this. +# +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $client - File descriptor connected to the client +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit +# Implicit Output: +# a reply is written to the client. + +sub PushFileHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + # At this time we only know that the IP of our partner is a valid manager + # the code below is a hook to do further authentication (e.g. to resolve + # spoofing). + + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + + # Now presumably we have the bona fides of both the peer host and the + # process making the request. + + my $reply = PushFile($userinput); + Reply($client, "$reply\n", $userinput); + + } else { + Failure( $client, "refused\n", $userinput); + } +} +RegisterHandler("pushfile", \&PushFileHandler, 1, 0, 1); + + + +# Process a reinit request. Reinit requests that either +# lonc or lond be reinitialized so that an updated +# host.tab or domain.tab can be processed. +# +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $client - File descriptor connected to the client +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit +# Implicit output: +# a reply is sent to the client. +# +sub ReinitProcessHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + chomp($userinput); + my $reply = ReinitProcess($userinput); + Reply( $client, "$reply\n", $userinput); + } else { + Failure( $client, "refused\n", $userinput); + } + return 1; +} + +RegisterHandler("reinit", \&ReinitProcessHandler, 1, 0, 1); + +# Process the editing script for a table edit operation. +# the editing operation must be encrypted and requested by +# a manager host. +# +# Parameters: +# $cmd - the actual keyword that invoked us. +# $tail - the tail of the request that invoked us. +# $client - File descriptor connected to the client +# Returns: +# 1 - Ok to continue processing. +# 0 - Program should exit +# Implicit output: +# a reply is sent to the client. +# +sub EditTableHandler { + my $command = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$command:$tail"; + + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + my($filetype, $script) = split(/:/, $tail); + if (($filetype eq "hosts") || + ($filetype eq "domain")) { + if($script ne "") { + Reply($client, # BUGBUG - EditFile + EditFile($userinput), # could fail. + $userinput); + } else { + Failure($client,"refused\n",$userinput); + } + } else { + Failure($client,"refused\n",$userinput); + } + } else { + Failure($client,"refused\n",$userinput); + } + return 1; +} +RegisterHandler("edit", \&EditTableHandler, 1, 0, 1); + + +# +# Authenticate a user against the LonCAPA authentication +# database. Note that there are several authentication +# possibilities: +# - unix - The user can be authenticated against the unix +# password file. +# - internal - The user can be authenticated against a purely +# internal per user password file. +# - kerberos - The user can be authenticated against either a kerb4 or kerb5 +# ticket granting authority. +# - user - The person tailoring LonCAPA can supply a user authentication +# mechanism that is per system. +# +# 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. +# Implicit inputs: +# The authentication systems describe above have their own forms of implicit +# input into the authentication process that are described above. +# +sub AuthenticateHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + # Regenerate the full input line + + my $userinput = $cmd.":".$tail; + + # udom - User's domain. + # uname - Username. + # upass - User's password. + + my ($udom,$uname,$upass)=split(/:/,$tail); + Debug(" Authenticate domain = $udom, user = $uname, password = $upass"); + chomp($upass); + $upass=unescape($upass); + + my $pwdcorrect = ValidateUser($udom, $uname, $upass); + if($pwdcorrect) { + Reply( $client, "authorized\n", $userinput); + # + # Bad credentials: Failed to authorize + # + } else { + Failure( $client, "non_authorized\n", $userinput); + } + + return 1; +} +RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0); + +# +# Change a user's password. Note that this function is complicated by +# the fact that a user may be authenticated in more than one way: +# At present, we are not able to change the password for all types of +# authentication methods. Only for: +# unix - unix password or shadow passoword style authentication. +# local - Locally written authentication mechanism. +# For now, kerb4 and kerb5 password changes are not supported and result +# in an error. +# FUTURE WORK: +# Support kerberos passwd changes? +# 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. +# Implicit inputs: +# The authentication systems describe above have their own forms of implicit +# input into the authentication process that are described above. +sub ChangePasswordHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = $cmd.":".$tail; # Reconstruct client's string. + + # + # udom - user's domain. + # uname - Username. + # upass - Current password. + # npass - New password. + + my ($udom,$uname,$upass,$npass)=split(/:/,$tail); + + $upass=&unescape($upass); + $npass=&unescape($npass); + &Debug("Trying to change password for $uname"); + + # First require that the user can be authenticated with their + # old password: + + my $validated = ValidateUser($udom, $uname, $upass); + if($validated) { + my $realpasswd = GetAuthType($udom, $uname); # Defined since authd. + + my ($howpwd,$contentpwd)=split(/:/,$realpasswd); + if ($howpwd eq 'internal') { + &Debug("internal auth"); + my $salt=time; + $salt=substr($salt,6,2); + my $ncpass=crypt($npass,$salt); + if(RewritePwFile($udom, $uname, "internal:$ncpass")) { + &logthis("Result of password change for " + ."$uname: pwchange_success"); + Reply($client, "ok\n", $userinput); + } else { + &logthis("Unable to open $uname passwd " + ."to change password"); + Failure( $client, "non_authorized\n",$userinput); + } + } elsif ($howpwd eq 'unix') { + # Unix means we have to access /etc/password + &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: ". + &lcpasswdstrerror($?)); + Reply($client, "$result\n", $userinput); + } else { + # this just means that the current password mode is not + # one we know how to change (e.g the kerberos auth modes or + # locally written auth handler). + # + Reply( $client, "auth_mode_error\n", $userinput); + } + + } + else { + Reply( $client, "non_authorized\n", $userinput); + } + + return 1; +} +RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0); + +# +# Create a new user. User in this case means a lon-capa user. +# The user must either already exist in some authentication realm +# like kerberos or the /etc/passwd. If not, a user completely local to +# this loncapa system is created. +# +# 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. +# Implicit inputs: +# The authentication systems describe above have their own forms of implicit +# input into the authentication process that are described above. +sub AddUserHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my ($udom,$uname,$umode,$npass)=split(/:/,$tail); + my $userinput = $cmd.":".$tail; # Reconstruct the full request line. + + &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname); + + + if($udom eq $currentdomainid) { # Reject new users for other domains... + + my $oldumask=umask(0077); + chomp($npass); + $npass=&unescape($npass); + my $passfilename = PasswordPath($udom, $uname); + &Debug("Password file created will be:".$passfilename); + if (-e $passfilename) { + Failure( $client, "already_exists\n", $userinput); + } else { + my @fpparts=split(/\//,$passfilename); + my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; + my $fperror=''; + for (my $i=3;$i<= ($#fpparts-1);$i++) { + $fpnow.='/'.$fpparts[$i]; + unless (-e $fpnow) { + &logthis("mkdir $fpnow"); + unless (mkdir($fpnow,0777)) { + $fperror="error: ".($!+0)." mkdir failed while attempting " + ."makeuser"; + } + } + } + unless ($fperror) { + my $result=&make_passwd_file($uname, $umode,$npass, $passfilename); + Reply($client, $result, $userinput); #BUGBUG - could be fail + } else { + Failure($client, "$fperror\n", $userinput); + } + } + umask($oldumask); + } else { + Failure($client, "not_right_domain\n", + $userinput); # Even if we are multihomed. + + } + return 1; + +} +RegisterHandler("makeuser", \&AddUserHandler, 1, 1, 0); + +# +# Change the authentication method of a user. Note that this may +# also implicitly change the user's password if, for example, the user is +# joining an existing authentication realm. Known authentication realms at +# this time are: +# internal - Purely internal password file (only loncapa knows this user) +# local - Institutionally written authentication module. +# unix - Unix user (/etc/passwd with or without /etc/shadow). +# kerb4 - kerberos version 4 +# kerb5 - kerberos version 5 +# +# 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. +# Implicit inputs: +# The authentication systems describe above have their own forms of implicit +# input into the authentication process that are described above. +# +sub ChangeAuthenticationHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; # Reconstruct user input. + + my ($udom,$uname,$umode,$npass)=split(/:/,$tail); + &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode); + if ($udom ne $currentdomainid) { + Failure( $client, "not_right_domain\n", $client); + } else { + + chomp($npass); + + $npass=&unescape($npass); + my $passfilename = PasswordPath($udom, $uname); + if ($passfilename) { # Not allowed to create a new user!! + my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); + Reply($client, $result, $userinput); + } else { + Failure($client, "non_authorized", $userinput); # Fail the user now. + } + } + return 1; +} +RegisterHandler("changeuserauth", \&ChangeAuthenticationHandler, 1,1, 0); + +# +# Determines if this is the home server for a user. The home server +# for a user will have his/her lon-capa passwd file. Therefore all we need +# to do is determine if this file 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. +# Implicit inputs: +# The authentication systems describe above have their own forms of implicit +# input into the authentication process that are described above. +# +sub IsHomeHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($udom,$uname)=split(/:/,$tail); + chomp($uname); + my $passfile = PasswordFilename($udom, $uname); + if($passfile) { + Reply( $client, "found\n", $userinput); + } else { + Failure($client, "not_found\n", $userinput); + } + return 1; +} +RegisterHandler("home", \&IsHomeHandler, 0,1,0); +# +# Process an update request for a resource?? I think what's going on here is +# that a resource has been modified that we hold a subscription to. +# If the resource is not local, then we must update, or at least invalidate our +# cached copy of the resource. +# FUTURE WORK: +# I need to look at this logic carefully. My druthers would be to follow +# typical caching logic, and simple invalidate the cache, drop any subscription +# an let the next fetch start the ball rolling again... however that may +# actually be more difficult than it looks given the complex web of +# proxy servers. +# 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. +# Implicit inputs: +# The authentication systems describe above have their own forms of implicit +# input into the authentication process that are described above. +# +sub UpdateResourceHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my $fname= $tail; # This allows interactive testing + + + my $ownership=ishome($fname); + if ($ownership eq 'not_owner') { + if (-e $fname) { + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname); + my $now=time; + my $since=$now-$atime; + if ($since>$perlvar{'lonExpire'}) { + my $reply=&reply("unsub:$fname","$clientname"); + unlink("$fname"); + } else { + my $transname="$fname.in.transfer"; + my $remoteurl=&reply("sub:$fname","$clientname"); + my $response; + alarm(120); + { + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"$remoteurl"); + $response=$ua->request($request,$transname); + } + alarm(0); + if ($response->is_error()) { + unlink($transname); + my $message=$response->status_line; + &logthis("LWP GET: $message for $fname ($remoteurl)"); + } else { + if ($remoteurl!~/\.meta$/) { + alarm(120); + { + my $ua=new LWP::UserAgent; + my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); + my $mresponse=$ua->request($mrequest,$fname.'.meta'); + if ($mresponse->is_error()) { + unlink($fname.'.meta'); + } + } + alarm(0); + } + rename($transname,$fname); + } + } + Reply( $client, "ok\n", $userinput); + } else { + Failure($client, "not_found\n", $userinput); + } + } else { + Failure($client, "rejected\n", $userinput); + } + return 1; +} +RegisterHandler("update", \&UpdateResourceHandler, 0 ,1, 0); + +# +# Fetch a user file from a remote server: +# 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 FetchUserFileHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + my $fname = $tail; + my ($udom,$uname,$ufile)=split(/\//,$fname); + my $udir=propath($udom,$uname).'/userfiles'; + unless (-e $udir) { + mkdir($udir,0770); + } + if (-e $udir) { + $ufile=~s/^[\.\~]+//; + $ufile=~s/\///g; + my $destname=$udir.'/'.$ufile; + my $transname=$udir.'/'.$ufile.'.in.transit'; + my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; + my $response; + alarm(120); + { + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"$remoteurl"); + $response=$ua->request($request,$transname); + } + alarm(0); + if ($response->is_error()) { + unlink($transname); + my $message=$response->status_line; + &logthis("LWP GET: $message for $fname ($remoteurl)"); + Failure($client, "failed\n", $userinput); + } else { + if (!rename($transname,$destname)) { + &logthis("Unable to move $transname to $destname"); + unlink($transname); + Failure($client, "failed\n", $userinput); + } else { + Reply($client, "ok\n", $userinput); + } + } + } else { + Failure($client, "not_home\n", $userinput); + } + return 1; +} +RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0); +# +# Authenticate access to a user file. +# +# 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 AuthenticateUserFileAccess { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + my ($fname,$session)=split(/:/,$tail); + chomp($session); + my $reply='non_auth'; + if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.$session.'.id')) { + while (my $line=) { + if ($line=~/userfile\.$fname\=/) { + $reply='ok'; + } + } + close(ENVIN); + Reply($client, $reply."\n", $userinput); + } else { + Failure($client, "invalid_token\n", $userinput); + } + return 1; + +} +RegisterHandler("tokenauthuserfile", \&AuthenticateUserFileAccess, 0, 1, 0); +# +# Unsubscribe from a resource. +# +# 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 UnsubscribeHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput= "$cmd:$tail"; + + my ($fname) = $tail; + + Debug("Unsubscribing $fname"); + if (-e $fname) { + Debug("Exists"); + Reply($client, &unsub($fname,$clientip), $userinput); + } else { + Failure($client, "not_found\n", $userinput); + } + return 1; +} +RegisterHandler("unsub", \&UnsubscribeHandler, 0, 1, 0); + +# Subscribe to a resource +# +# 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 SubscribeHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + Reply( $client, &subscribe($userinput,$clientip), $userinput); + + return 1; +} +RegisterHandler("sub", \&SubscribeHandler, 0, 1, 0); + +# +# Determine the version of a resource (?) Or is it return +# the top version of the resource? Not yet clear from the +# code in currentversion. +# +# 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 CurrentVersionHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput= "$cmd:$tail"; + + my $fname = $tail; + Reply( $client, ¤tversion($fname)."\n", $userinput); + return 1; + +} +RegisterHandler("currentversion", \&CurrentVersionHandler, 0, 1, 0); + + +# Make an entry in a user's activity log. +# +# 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 ActivityLogEntryHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput= "$cmd:$tail"; + + my ($udom,$uname,$what)=split(/:/,$tail); + chomp($what); + my $proname=propath($udom,$uname); + my $now=time; + my $hfh; + if ($hfh=IO::File->new(">>$proname/activity.log")) { + print $hfh "$now:$clientname:$what\n"; + Reply( $client, "ok\n", $userinput); + } else { + Failure($client, "error: ".($!+0)." IO::File->new Failed " + ."while attempting log\n", + $userinput); + } + + return 1; +} +RegisterHandler("log", \&ActivityLogEntryHandler, 0, 1, 0); +# +# Put a namespace entry in a user profile hash. +# My druthers would be for this to be an encrypted interaction too. +# anything that might be an inadvertent covert channel about either +# user authentication or user personal information.... +# +# 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 PutUserProfileEntry { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + my ($udom,$uname,$namespace,$what) =split(/:/,$tail); + if ($namespace ne 'roles') { + chomp($what); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(),"P",$what); + if($hashref) { + my @pairs=split(/\&/,$what); + 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); + } + } else { + Failure( $client, "error: ".($!)." tie(GDBM) Failed ". + "while attempting put\n", $userinput); + } + } else { + Failure( $client, "refused\n", $userinput); + } + + return 1; +} +RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0); + +# +# Increment a profile entry in the user history file. +# The history contains keyword value pairs. In this case, +# The value itself is a pair of numbers. The first, the current value +# the second an increment that this function applies to the current +# value. +# +# 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 IncrementUserValueHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + my ($udom,$uname,$namespace,$what) =split(/:/,$tail); + if ($namespace ne 'roles') { + chomp($what); + my $hashref = TieUserHash($udom, $uname, + $namespace, &GDBM_WRCREAT(), + "P",$what); + if ($hashref) { + my @pairs=split(/\&/,$what); + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + # We could check that we have a number... + if (! defined($value) || $value eq '') { + $value = 1; + } + $hashref->{$key}+=$value; + } + if (untie(%$hashref)) { + Reply( $client, "ok\n", $userinput); + } else { + Failure($client, "error: ".($!+0)." untie(GDBM) failed ". + "while attempting inc\n", $userinput); + } + } else { + Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting inc\n", $userinput); + } + } else { + Failure($client, "refused\n", $userinput); + } + + return 1; +} +RegisterHandler("inc", \&IncrementUserValueHandler, 0, 1, 0); +# +# Put a new role for a user. Roles are LonCAPA's packaging of permissions. +# Each 'role' a user has implies a set of permissions. Adding a new role +# for a person grants the permissions packaged with that role +# to that user when the role is selected. +# +# Parameters: +# $cmd - The command string (rolesput). +# $tail - The remainder of the request line. For rolesput this +# consists of a colon separated list that contains: +# The domain and user that is granting the role (logged). +# The domain and user that is getting the role. +# The roles being granted as a set of & separated pairs. +# each pair a key value pair. +# $client - File descriptor connected to the client. +# Returns: +# 0 - If the daemon should exit +# 1 - To continue processing. +# +# +sub RolesPutHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + my ( $exedom, $exeuser, $udom, $uname, $what) = split(/:/,$tail); + + + my $namespace='roles'; + chomp($what); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(), "P", + "$exedom:$exeuser:$what"); + # + # Log the attempt to set a role. The {}'s here ensure that the file + # handle is open for the minimal amount of time. Since the flush + # is done on close this improves the chances the log will be an un- + # corrupted ordered thing. + if ($hashref) { + my @pairs=split(/\&/,$what); + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + &ManagePermissions($key, $udom, $uname, + &GetAuthType( $udom, $uname)); + $hashref->{$key}=$value; + } + if (untie($hashref)) { + Reply($client, "ok\n", $userinput); + } else { + Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting rolesput\n", $userinput); + } + } else { + Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting rolesput\n", $userinput); + } + return 1; +} +RegisterHandler("rolesput", \&RolesPutHandler, 1,1,0); # Encoded client only. +# +# Deletes (removes) a role for a user. This is equivalent to removing +# a permissions package associated with the role from the user's profile. +# +# Parameters: +# $cmd - The command (rolesdel) +# $tail - The remainder of the request line. This consists +# of: +# The domain and user requesting the change (logged) +# The domain and user being changed. +# The roles being revoked. These are shipped to us +# as a bunch of & separated role name keywords. +# $client - The file handle open on the client. +# Returns: +# 1 - Continue processing +# 0 - Exit. +# +sub RolesDeleteHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail); + &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom. + "what = ".$what); + my $namespace='roles'; + chomp($what); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(), "D", + "$exedom:$exeuser:$what"); + + if ($hashref) { + my @rolekeys=split(/\&/,$what); + + foreach my $key (@rolekeys) { + delete $hashref->{$key}; + } + if (untie(%$hashref)) { + Reply($client, "ok\n", $userinput); + } else { + Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting rolesdel\n", $userinput); + } + } else { + Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting rolesdel\n", $userinput); + } + + return 1; +} +RegisterHandler("rolesdel", \&RolesDeleteHandler, 1,1, 0); # Encoded client only + +# Unencrypted get from a user's profile database. See +# GetProfileEntryEncrypted for a version that does end-to-end encryption. +# This function retrieves a keyed item from a specific named database in the +# user's directory. +# +# Parameters: +# $cmd - Command request keyword (get). +# $tail - Tail of the command. This is a colon separated list +# consisting of the domain and username that uniquely +# identifies the profile, +# The 'namespace' which selects the gdbm file to +# do the lookup in, +# & separated list of keys to lookup. Note that +# the values are returned as an & separated list too. +# $client - File descriptor open on the client. +# Returns: +# 1 - Continue processing. +# 0 - Exit. +# +sub GetProfileEntry { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput= "$cmd:$tail"; + + my ($udom,$uname,$namespace,$what) = split(/:/,$tail); + chomp($what); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + my @queries=split(/\&/,$what); + my $qresult=''; + + for (my $i=0;$i<=$#queries;$i++) { + $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. + } + $qresult=~s/\&$//; # Remove trailing & from last lookup. + if (untie(%$hashref)) { + Reply($client, "$qresult\n", $userinput); + } else { + Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting get\n", $userinput); + } + } else { + if ($!+0 == 2) { # +0 coerces errno -> number 2 is ENOENT + Failure($client, "error:No such file or ". + "GDBM reported bad block error\n", $userinput); + } else { # Some other undifferentiated err. + Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting get\n", $userinput); + } + } + return 1; +} +RegisterHandler("get", \&GetProfileEntry, 0,1,0); +# +# Process the encrypted get request. Note that the request is sent +# in clear, but the reply is encrypted. This is a small covert channel: +# information about the sensitive keys is given to the snooper. Just not +# information about the values of the sensitive key. Hmm if I wanted to +# know these I'd snoop for the egets. Get the profile item names from them +# and then issue a get for them since there's no enforcement of the +# requirement of an encrypted get for particular profile items. If I +# were re-doing this, I'd force the request to be encrypted as well as the +# reply. I'd also just enforce encrypted transactions for all gets since +# that would prevent any covert channel snooping. +# +# Parameters: +# $cmd - Command keyword of request (eget). +# $tail - Tail of the command. See GetProfileEntry # for more information about this. +# $client - File open on the client. +# Returns: +# 1 - Continue processing +# 0 - server should exit. +sub GetProfileEntryEncrypted { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput); + chomp($what); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + my @queries=split(/\&/,$what); + my $qresult=''; + for (my $i=0;$i<=$#queries;$i++) { + $qresult.="$hashref->{$queries[$i]}&"; + } + if (untie(%$hashref)) { + $qresult=~s/\&$//; + if ($cipher) { + my $cmdlength=length($qresult); + $qresult.=" "; + my $encqresult=''; + for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { + $encqresult.= unpack("H16", + $cipher->encrypt(substr($qresult, + $encidx, + 8))); + } + Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput); + } else { + Failure( $client, "error:no_key\n", $userinput); + } + } else { + Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting eget\n", $userinput); + } + } else { + Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting eget\n", $userinput); + } + + return 1; +} +RegisterHandler("eget", \&GetProfileEntryEncrypted, 0, 1, 0); + +# +# Deletes a key in a user profile database. +# +# Parameters: +# $cmd - Command keyword (del). +# $tail - Command tail. IN this case a colon +# separated list containing: +# The domain and user that identifies uniquely +# the identity of the user. +# The profile namespace (name of the profile +# database file). +# & separated list of keywords to delete. +# $client - File open on client socket. +# Returns: +# 1 - Continue processing +# 0 - Exit server. +# +# + +sub DeleteProfileEntry { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "cmd:$tail"; + + my ($udom,$uname,$namespace,$what) = split(/:/,$tail); + chomp($what); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(), + "D",$what); + if ($hashref) { + my @keys=split(/\&/,$what); + foreach my $key (@keys) { + delete($hashref->{$key}); + } + if (untie(%$hashref)) { + Reply($client, "ok\n", $userinput); + } else { + Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting del\n", $userinput); + } + } else { + Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting del\n", $userinput); + } + return 1; +} +RegisterHandler("del", \&DeleteProfileEntry, 0, 1, 0); +# +# List the set of keys that are defined in a profile database file. +# A successful reply from this will contain an & separated list of +# the keys. +# Parameters: +# $cmd - Command request (keys). +# $tail - Remainder of the request, a colon separated +# list containing domain/user that identifies the +# user being queried, and the database namespace +# (database filename essentially). +# $client - File open on the client. +# Returns: +# 1 - Continue processing. +# 0 - Exit the server. +# +sub GetProfileKeys { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + my ($udom,$uname,$namespace)=split(/:/,$tail); + my $qresult=''; + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + foreach my $key (keys %$hashref) { + $qresult.="$key&"; + } + if (untie(%$hashref)) { + $qresult=~s/\&$//; + Reply($client, "$qresult\n", $userinput); + } else { + Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting keys\n", $userinput); + } + } else { + Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting keys\n", $userinput); + } + + return 1; +} +RegisterHandler("keys", \&GetProfileKeys, 0, 1, 0); +# +# Dump the contents of a user profile database. +# Note that this constitutes a very large covert channel too since +# the dump will return sensitive information that is not encrypted. +# The naive security assumption is that the session negotiation ensures +# our client is trusted and I don't believe that's assured at present. +# Sure want badly to go to ssl or tls. Of course if my peer isn't really +# a LonCAPA node they could have negotiated an encryption key too so >sigh<. +# +# Parameters: +# $cmd - The command request keyword (currentdump). +# $tail - Remainder of the request, consisting of a colon +# separated list that has the domain/username and +# the namespace to dump (database file). +# $client - file open on the remote client. +# Returns: +# 1 - Continue processing. +# 0 - Exit the server. +# +sub DumpProfileDatabase { + my $cmd = shift; + my $tail = shift; + my $client = shift; + my $userinput = "$cmd:$tail"; + + my ($udom,$uname,$namespace) = split(/:/,$tail); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + # Structure of %data: + # $data{$symb}->{$parameter}=$value; + # $data{$symb}->{'v.'.$parameter}=$version; + # since $parameter will be unescaped, we do not + # have to worry about silly parameter names... + + my $qresult=''; + my %data = (); # A hash of anonymous hashes.. + while (my ($key,$value) = each(%$hashref)) { + my ($v,$symb,$param) = split(/:/,$key); + next if ($v eq 'version' || $symb eq 'keys'); + next if (exists($data{$symb}) && + exists($data{$symb}->{$param}) && + $data{$symb}->{'v.'.$param} > $v); + $data{$symb}->{$param}=$value; + $data{$symb}->{'v.'.$param}=$v; + } + if (untie(%$hashref)) { + while (my ($symb,$param_hash) = each(%data)) { + while(my ($param,$value) = each (%$param_hash)){ + next if ($param =~ /^v\./); # Ignore versions... + # + # Just dump the symb=value pairs separated by & + # + $qresult.=$symb.':'.$param.'='.$value.'&'; + } + } + chop($qresult); + Reply($client , "$qresult\n", $userinput); + } else { + Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting currentdump\n", $userinput); + } + } else { + Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting currentdump\n", $userinput); + } + + return 1; +} +RegisterHandler("currentdump", \&DumpProfileDatabase, 0, 1, 0); +# +# Dump a profile database with an optional regular expression +# to match against the keys. In this dump, no effort is made +# to separate symb from version information. Presumably the +# databases that are dumped by this command are of a different +# structure. Need to look at this and improve the documentation of +# both this and the currentdump handler. +# Parameters: +# $cmd - The command keyword. +# $tail - All of the characters after the $cmd: +# These are expected to be a colon +# separated list containing: +# domain/user - identifying the user. +# namespace - identifying the database. +# regexp - optional regular expression +# that is matched against +# database keywords to do +# selective dumps. +# $client - Channel open on the client. +# Returns: +# 1 - Continue processing. +# Side effects: +# response is written to $client. +# +sub DumpWithRegexp { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); + if (defined($regexp)) { + $regexp=&unescape($regexp); + } else { + $regexp='.'; + } + my $hashref =TieUserHash($udom, $uname, $namespace, + &GDBM_READER()); + if ($hashref) { + my $qresult=''; + while (my ($key,$value) = each(%$hashref)) { + if ($regexp eq '.') { + $qresult.=$key.'='.$value.'&'; + } else { + my $unescapeKey = &unescape($key); + if (eval('$unescapeKey=~/$regexp/')) { + $qresult.="$key=$value&"; + } + } + } + if (untie(%$hashref)) { + chop($qresult); + Reply($client, "$qresult\n", $userinput); + } else { + Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting dump\n", $userinput); + } + } else { + Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting dump\n", $userinput); + } + + return 1; +} +RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0); + +# Store a set of key=value pairs associated with a versioned name. +# +# Parameters: +# $cmd - Request command keyword. +# $tail - Tail of the request. This is a colon +# separated list containing: +# domain/user - User and authentication domain. +# namespace - Name of the database being modified +# rid - Resource keyword to modify. +# what - new value associated with rid. +# +# $client - Socket open on the client. +# +# +# Returns: +# 1 (keep on processing). +# Side-Effects: +# Writes to the client +sub StoreHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail); + if ($namespace ne 'roles') { + + chomp($what); + my @pairs=split(/\&/,$what); + my $hashref = TieUserHash($udom, $uname, $namespace, + &GDBM_WRCREAT(), "P", + "$rid:$what"); + if ($hashref) { + my $now = time; + my @previouskeys=split(/&/,$hashref->{"keys:$rid"}); + my $key; + $hashref->{"version:$rid"}++; + my $version=$hashref->{"version:$rid"}; + my $allkeys=''; + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + $allkeys.=$key.':'; + $hashref->{"$version:$rid:$key"}=$value; + } + $hashref->{"$version:$rid:timestamp"}=$now; + $allkeys.='timestamp'; + $hashref->{"$version:keys:$rid"}=$allkeys; + if (untie($hashref)) { + Reply($client, "ok\n", $userinput); + } else { + Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting store\n", $userinput); + } + } else { + Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting store\n", $userinput); + } + } else { + Failure($client, "refused\n", $userinput); + } + + return 1; +} +RegisterHandler("store", \&StoreHandler, 0, 1, 0); +# +# Dump out all versions of a resource that has key=value pairs associated +# with it for each version. These resources are built up via the store +# command. +# +# Parameters: +# $cmd - Command keyword. +# $tail - Remainder of the request which consists of: +# domain/user - User and auth. domain. +# namespace - name of resource database. +# rid - Resource id. +# $client - socket open on the client. +# +# Returns: +# 1 indicating the caller should not yet exit. +# Side-effects: +# Writes a reply to the client. +# The reply is a string of the following shape: +# version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2... +# Where the 1 above represents version 1. +# this continues for all pairs of keys in all versions. +# +# +# +# +sub RestoreHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; # Only used for logging purposes. + + my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput); + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; + chomp($rid); + my $proname=propath($udom,$uname); + my $qresult=''; + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db", + &GDBM_READER(),0640)) { + my $version=$hash{"version:$rid"}; + $qresult.="version=$version&"; + my $scope; + for ($scope=1;$scope<=$version;$scope++) { + my $vkeys=$hash{"$scope:keys:$rid"}; + my @keys=split(/:/,$vkeys); + my $key; + $qresult.="$scope:keys=$vkeys&"; + foreach $key (@keys) { + $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; + } + } + if (untie(%hash)) { + $qresult=~s/\&$//; + Reply( $client, "$qresult\n", $userinput); + } else { + Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting restore\n", $userinput); + } + } else { + Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting restore\n", $userinput); + } + + return 1; + + +} +RegisterHandler("restore", \&RestoreHandler, 0,1,0); + +# +# Add a chat message to to a discussion board. +# +# Parameters: +# $cmd - Request keyword. +# $tail - Tail of the command. A colon separated list +# containing: +# cdom - Domain on which the chat board lives +# cnum - Identifier of the discussion group. +# post - Body of the posting. +# $client - Socket open on the client. +# Returns: +# 1 - Indicating caller should keep on processing. +# +# Side-effects: +# writes a reply to the client. +# +# +sub SendChatHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($cdom,$cnum,$newpost)=split(/\:/,$tail); + &chatadd($cdom,$cnum,$newpost); + Reply($client, "ok\n", $userinput); + + return 1; +} +RegisterHandler("chatsend", \&SendChatHandler, 0, 1, 0); +# +# Retrieve the set of chat messagss from a discussion board. +# +# Parameters: +# $cmd - Command keyword that initiated the request. +# $tail - Remainder of the request after the command +# keyword. In this case a colon separated list of +# chat domain - Which discussion board. +# chat id - Discussion thread(?) +# domain/user - Authentication domain and username +# of the requesting person. +# $client - Socket open on the client program. +# Returns: +# 1 - continue processing +# Side effects: +# Response is written to the client. +# +sub RetrieveChatHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail); + my $reply=''; + foreach (&getchat($cdom,$cnum,$udom,$uname)) { + $reply.=&escape($_).':'; + } + $reply=~s/\:$//; + Reply($client, $reply."\n", $userinput); + + + return 1; +} +RegisterHandler("chatretr", \&RetrieveChatHandler, 0, 1, 0); +# +# Initiate a query of an sql database. SQL query repsonses get put in +# a file for later retrieval. This prevents sql query results from +# bottlenecking the system. Note that with loncnew, perhaps this is +# less of an issue since multiple outstanding requests can be concurrently +# serviced. +# +# Parameters: +# $cmd - COmmand keyword that initiated the request. +# $tail - Remainder of the command after the keyword. +# For this function, this consists of a query and +# 3 arguments that are self-documentingly labelled +# in the original arg1, arg2, arg3. +# $client - Socket open on the client. +# Return: +# 1 - Indicating processing should continue. +# Side-effects: +# a reply is written to $client. +# +sub SendQueryHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail); + $query=~s/\n*$//g; + Reply($client, "". sqlreply("$clientname\&$query". + "\&$arg1"."\&$arg2"."\&$arg3")."\n", + $userinput); + + return 1; +} +RegisterHandler("querysend", \&SendQueryHandler, 0, 1, 0); + +# +# Add a reply to an sql query. SQL queries are done asyncrhonously. +# The query is submitted via a "querysend" transaction. +# There it is passed on to the lonsql daemon, queued and issued to +# mysql. +# This transaction is invoked when the sql transaction is complete +# it stores the query results in flie and indicates query completion. +# presumably local software then fetches this response... I'm guessing +# the sequence is: lonc does a querysend, we ask lonsql to do it. +# lonsql on completion of the query interacts with the lond of our +# client to do a query reply storing two files: +# - id - The results of the query. +# - id.end - Indicating the transaction completed. +# NOTE: id is a unique id assigned to the query and querysend time. +# Parameters: +# $cmd - Command keyword that initiated this request. +# $tail - Remainder of the tail. In this case that's a colon +# separated list containing the query Id and the +# results of the query. +# $client - Socket open on the client. +# Return: +# 1 - Indicating that we should continue processing. +# Side effects: +# ok written to the client. +# +sub ReplyQueryHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($cmd,$id,$reply)=split(/:/,$userinput); + my $store; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new(">$execdir/tmp/$id")) { + $reply=~s/\&/\n/g; + print $store $reply; + close $store; + my $store2=IO::File->new(">$execdir/tmp/$id.end"); + print $store2 "done\n"; + close $store2; + Reply($client, "ok\n", $userinput); + } else { + Failure($client, "error: ".($!+0) + ." IO::File->new Failed ". + "while attempting queryreply\n", $userinput); + } + + + return 1; +} +RegisterHandler("queryreply", \&ReplyQueryHandler, 0, 1, 0); +# +# Process the courseidput query. Not quite sure what this means +# at the system level sense. It appears a gdbm file in the +# /home/httpd/lonUsers/$domain/nohist_courseids is tied and +# a set of entries made in that database. +# +# Parameters: +# $cmd - The command keyword that initiated this request. +# $tail - Tail of the command. In this case consists of a colon +# separated list contaning the domain to apply this to and +# an ampersand separated list of keyword=value pairs. +# $client - Socket open on the client. +# Returns: +# 1 - indicating that processing should continue +# +# Side effects: +# reply is written to the client. +# +sub PutCourseIdHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($udom, $what) = split(/:/, $tail); + chomp($what); + my $now=time; + my @pairs=split(/\&/,$what); + + my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT()); + if ($hashref) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + $hashref->{$key}=$value.':'.$now; + } + if (untie(%$hashref)) { + Reply($client, "ok\n", $userinput); + } else { + Failure( $client, "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting courseidput\n", $userinput); + } + } else { + Failure( $client, "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting courseidput\n", $userinput); + } + + return 1; +} +RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0); + +# Retrieves the value of a course id resource keyword pattern +# defined since a starting date. Both the starting date and the +# keyword pattern are optional. If the starting date is not supplied it +# is treated as the beginning of time. If the pattern is not found, +# it is treatred as "." matching everything. +# +# Parameters: +# $cmd - Command keyword that resulted in us being dispatched. +# $tail - The remainder of the command that, in this case, consists +# of a colon separated list of: +# domain - The domain in which the course database is +# defined. +# since - Optional parameter describing the minimum +# time of definition(?) of the resources that +# will match the dump. +# description - regular expression that is used to filter +# the dump. Only keywords matching this regexp +# will be used. +# $client - The socket open on the client. +# Returns: +# 1 - Continue processing. +# Side Effects: +# a reply is written to $client. +sub DumpCourseIdHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($udom,$since,$description) =split(/:/,$tail); + if (defined($description)) { + $description=&unescape($description); + } else { + $description='.'; + } + unless (defined($since)) { $since=0; } + my $qresult=''; + logthis(" Looking for $description since $since"); + my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT()); + if ($hashref) { + while (my ($key,$value) = each(%$hashref)) { + my ($descr,$lasttime)=split(/\:/,$value); + logthis("Got: key = $key descr = $descr time: $lasttime"); + if ($lasttime<$since) { + logthis("Skipping .. too early"); + next; + } + if ($description eq '.') { + logthis("Adding wildcard match"); + $qresult.=$key.'='.$descr.'&'; + } else { + my $unescapeVal = &unescape($descr); + logthis("Matching with $unescapeVal"); + if (eval('$unescapeVal=~/$description/i')) { + logthis("Adding on match"); + $qresult.="$key=$descr&"; + } + } + } + if (untie(%$hashref)) { + chop($qresult); + Reply($client, "$qresult\n", $userinput); + } else { + Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting courseiddump\n", $userinput); + } + } else { + Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting courseiddump\n", $userinput); + } + + + return 1; +} +RegisterHandler("courseiddump", \&DumpCourseIdHandler, 0, 1, 0); +# +# Puts an id to a domains id database. +# +# Parameters: +# $cmd - The command that triggered us. +# $tail - Remainder of the request other than the command. This is a +# colon separated list containing: +# $domain - The domain for which we are writing the id. +# $pairs - The id info to write... this is and & separated list +# of keyword=value. +# $client - Socket open on the client. +# Returns: +# 1 - Continue processing. +# Side effects: +# reply is written to $client. +# +sub PutIdHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my @pairs=split(/\&/,$what); + my $hashref = TieDomainHash($udom, "ids", &GDBM_WRCREAT(), + "P", $what); + if ($hashref) { + 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 idput\n", $userinput); + } + } else { + Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting idput\n", $userinput); + } + + return 1; +} + +RegisterHandler("idput", \&PutIdHandler, 0, 1, 0); +# +# Retrieves a set of id values from the id database. +# Returns an & separated list of results, one for each requested id to the +# client. +# +# Parameters: +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose id table we dump +# ids Consists of an & separated list of +# id keywords whose values will be fetched. +# nonexisting keywords will have an empty value. +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects: +# An & separated list of results is written to $client. +# +sub GetIdHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$client:$tail"; + + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my @queries=split(/\&/,$what); + my $qresult=''; + my $hashref = TieDomainHash($udom, "ids", &GDBM_READER()); + if ($hashref) { + for (my $i=0;$i<=$#queries;$i++) { + $qresult.="$hashref->{$queries[$i]}&"; + } + if (untie(%$hashref)) { + $qresult=~s/\&$//; + Reply($client, "$qresult\n", $userinput); + } else { + Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting idget\n",$userinput); + } + } else { + Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting idget\n",$userinput); + } + + return 1; +} + +RegisterHandler("idget", \&GetIdHandler, 0, 1, 0); +# +# Process the tmpput command I'm not sure what this does.. Seems to +# create a file in the lonDaemons/tmp directory of the form $id.tmp +# where Id is the client's ip concatenated with a sequence number. +# The file will contain some value that is passed in. Is this e.g. +# a login token? +# +# Parameters: +# $cmd - The command that got us dispatched. +# $tail - The remainder of the request following $cmd: +# In this case this will be the contents of the file. +# $client - Socket connected to the client. +# Returns: +# 1 indicating processing can continue. +# Side effects: +# A file is created in the local filesystem. +# A reply is sent to the client. +sub TmpPutHandler { + my $cmd = shift; + my $what = shift; + my $client = shift; + + my $userinput = "$cmd:$what"; # Reconstruct for logging. + + + my $store; + $tmpsnum++; + my $id=$$.'_'.$clientip.'_'.$tmpsnum; + $id=~s/\W/\_/g; + $what=~s/\n//g; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { + print $store $what; + close $store; + Reply($client, "$id\n", $userinput); + } else { + Failure( $client, "error: ".($!+0)."IO::File->new Failed ". + "while attempting tmpput\n", $userinput); + } + return 1; + +} +RegisterHandler("tmpput", \&TmpPutHandler, 0, 1, 0); + +# Processes the tmpget command. This command returns the contents +# of a temporary resource file(?) created via tmpput. +# +# Paramters: +# $cmd - Command that got us dispatched. +# $id - Tail of the command, contain the id of the resource +# we want to fetch. +# $client - socket open on the client. +# Return: +# 1 - Inidcating processing can continue. +# Side effects: +# A reply is sent to the client. + +# +sub TmpGetHandler { + my $cmd = shift; + my $id = shift; + my $client = shift; + my $userinput = "$cmd:$id"; + + + $id=~s/\W/\_/g; + my $store; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { + my $reply=<$store>; + Reply( $client, "$reply\n", $userinput); + close $store; + } else { + Failure( $client, "error: ".($!+0)."IO::File->new Failed ". + "while attempting tmpget\n", $userinput); + } + + return 1; +} +RegisterHandler("tmpget", \&TmpGetHandler, 0, 1, 0); +# +# Process the tmpdel command. This command deletes a temp resource +# created by the tmpput command. +# +# Parameters: +# $cmd - Command that got us here. +# $id - Id of the temporary resource created. +# $client - socket open on the client process. +# +# Returns: +# 1 - Indicating processing should continue. +# Side Effects: +# A file is deleted +# A reply is sent to the client. +sub TmpDelHandler { + my $cmd = shift; + my $id = shift; + my $client = shift; + + my $userinput= "$cmd:$id"; + + chomp($id); + $id=~s/\W/\_/g; + my $execdir=$perlvar{'lonDaemons'}; + if (unlink("$execdir/tmp/$id.tmp")) { + Reply($client, "ok\n", $userinput); + } else { + Failure( $client, "error: ".($!+0)."Unlink tmp Failed ". + "while attempting tmpdel\n", $userinput); + } + + return 1; + +} +RegisterHandler("tmpdel", \&TmpDelHandler, 0, 1, 0); +# +# ls - 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 LsHandler { + my $cmd = shift; + my $ulsdir = shift; + my $client = shift; + + my $userinput = "$cmd:$ulsdir"; + + chomp($ulsdir); + + my $ulsout=''; + my $ulsfn; + logthis("ls for '$ulsdir'"); + if (-e $ulsdir) { + logthis("ls - directory exists"); + if(-d $ulsdir) { + logthis("ls $ulsdir is a file"); + if (opendir(LSDIR,$ulsdir)) { + while ($ulsfn=readdir(LSDIR)) { + my @ulsstats=stat($ulsdir.'/'.$ulsfn); + $ulsout.=$ulsfn.'&'. + join('&',@ulsstats).':'; + } + 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); + + + return 1; +} +RegisterHandler("ls", \&LsHandler, 0, 1, 0); + + +# +# Processes the setannounce command. This command +# creates a file named announce.txt in the top directory of +# the documentn root and sets its contents. The announce.txt file is +# printed in its entirety at the LonCAPA login page. Note: +# once the announcement.txt fileis created it cannot be deleted. +# However, setting the contents of the file to empty removes the +# announcement from the login page of loncapa so who cares. +# +# Parameters: +# $cmd - The command that got us dispatched. +# $announcement - The text of the announcement. +# $client - Socket open on the client process. +# Retunrns: +# 1 - Indicating request processing should continue +# Side Effects: +# The file {DocRoot}/announcement.txt is created. +# A reply is sent to $client. +# +sub SetAnnounceHandler { + my $cmd = shift; + my $announcement = shift; + my $client = shift; + + my $userinput = "$cmd:$announcement"; + + chomp($announcement); + $announcement=&unescape($announcement); + if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. + '/announcement.txt')) { + print $store $announcement; + close $store; + Reply($client, "ok\n", $userinput); + } else { + Failure($client, "error: ".($!+0)."\n", $userinput); + } + + return 1; +} +RegisterHandler("setannounce", \&SetAnnounceHandler, 0, 1, 0); + +# +# Return the version of the daemon. This can be used to determine +# the compatibility of cross version installations or, alternatively to +# simply know who's out of date and who isn't. Note that the version +# is returned concatenated with the tail. +# Parameters: +# $cmd - the request that dispatched to us. +# $tail - Tail of the request (client's version?). +# $client - Socket open on the client. +#Returns: +# 1 - continue processing requests. +# Side Effects: +# Replies with version to $client. +sub GetVersionHandler { + my $client = shift; + my $tail = shift; + my $client = shift; + my $userinput = $client; + + Reply($client, &version($userinput)."\n", $userinput); + + + return 1; +} +RegisterHandler("version", \&GetVersionHandler, 0, 1, 0); + +# Set the current host and domain. This is used to support +# multihomed systems. Each IP of the system, or even separate daemons +# on the same IP can be treated as handling a separate lonCAPA virtual +# machine. This command selects the virtual lonCAPA. The client always +# knows the right one since it is lonc and it is selecting the domain/system +# from the hosts.tab file. +# Parameters: +# $cmd - Command that dispatched us. +# $tail - Tail of the command (domain/host requested). +# $socket - Socket open on the client. +# +# Returns: +# 1 - Indicates the program should continue to process requests. +# Side-effects: +# The default domain/system context is modified for this daemon. +# a reply is sent to the client. +# +sub SelectHostHandler { + my $cmd = shift; + my $tail = shift; + my $socket = shift; + + my $userinput ="$cmd:$tail"; + + Reply($client, &sethost($userinput)."\n", $userinput); + + + return 1; +} +RegisterHandler("sethost", \&SelectHostHandler, 0, 1, 0); + +# Process a request to exit: +# - "bye" is sent to the client. +# - The client socket is shutdown and closed. +# - We indicate to the caller that we should exit. +# Formal Parameters: +# $cmd - The command that got us here. +# $tail - Tail of the command (empty). +# $client - Socket open on the tail. +# Returns: +# 0 - Indicating the program should exit!! +# +sub ExitHandler { + my $cmd = shift; + my $tail = shift; + my $client = shift; + + my $userinput = "$cmd:$tail"; + + &logthis("Client $clientip ($clientname) hanging up: $userinput"); + Reply($client, "bye\n", $userinput); + $client->shutdown(2); # shutdown the socket forcibly. + $client->close(); + + return 0; +} +RegisterHandler("exit", \&ExitHandler, 0, 1,1); +RegisterHandler("init", \&ExitHandler, 0, 1,1); # RE-init is like exit. +RegisterHandler("quit", \&ExitHandler, 0, 1,1); # I like this too! +#------------------------------------------------------------------------------------ +# +# Process a Request. Takes a request from the client validates +# it and performs the operation requested by it. Returns +# a response to the client. +# +# Parameters: +# request - A string containing the user's request. +# Returns: +# 0 - Requested to exit, caller should shut down. +# 1 - Accept additional requests from the client. +# +sub ProcessRequest { + my $Request = shift; + my $KeepGoing = 1; # Assume we're not asked to stop. + + my $wasenc=0; + my $userinput = $Request; # for compatibility with oldcode + + +# ------------------------------------------------------------ See if encrypted + + if($userinput =~ /^enc/) { + $wasenc = 1; + $userinput = Decipher($userinput); + if(! $userinput) { + Failure($client,"error:Encrypted data without negotiating key"); + return 0; # Break off with this imposter. + } + } + # Split off the request keyword from the rest of the stuff. + + my ($command, $tail) = split(/:/, $userinput, 2); + chomp($command); + chomp($tail); + $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet. + + Debug("Command received: $command, encoded = $wasenc"); + + +# ------------------------------------------------------------- Normal commands + + # + # If the command is in the hash, then execute it via the hash dispatch: + # + if(defined $Dispatcher{$command}) { + + my $DispatchInfo = $Dispatcher{$command}; + my $Handler = $$DispatchInfo[0]; + my $NeedEncode = $$DispatchInfo[1]; + my $ClientTypes = $$DispatchInfo[2]; + Debug("Matched dispatch hash: mustencode: $NeedEncode ClientType $ClientTypes"); + + # Validate the request: + + my $ok = 1; + my $requesterprivs = 0; + if(isClient()) { + $requesterprivs |= $CLIENT_OK; + } + if(isManager()) { + $requesterprivs |= $MANAGER_OK; + } + if($NeedEncode && (!$wasenc)) { + Debug("Must encode but wasn't: $NeedEncode $wasenc"); + $ok = 0; + } + if(($ClientTypes & $requesterprivs) == 0) { + Debug("Client not privileged to do this operation"); + $ok = 0; + } + + if($ok) { + Debug("Dispatching to handler $command $tail"); + $KeepGoing = &$Handler($command, $tail, $client); + } else { + Debug("Refusing to dispatch because ok is false"); + Failure($client, "refused\n", $userinput); + } + + +# ------------------------------------------------------------- unknown command + + } else { + # unknown command + Failure($client, "unknown_cmd\n", $userinput); + } + + return $KeepGoing; +} + # # GetCertificate: Given a transaction that requires a certificate, @@ -212,6 +2780,57 @@ sub GetCertificate { } + +# +# ReadManagerTable: Reads in the current manager table. For now this is +# done on each manager authentication because: +# - These authentications are not frequent +# - This allows dynamic changes to the manager table +# without the need to signal to the lond. +# + +sub ReadManagerTable { + + # Clean out the old table first.. + + foreach my $key (keys %managers) { + delete $managers{$key}; + } + + my $tablename = $perlvar{'lonTabDir'}."/managers.tab"; + if (!open (MANAGERS, $tablename)) { + logthis('No manager table. Nobody can manage!!'); + return; + } + while(my $host = ) { + chomp($host); + if ($host =~ "^#") { # Comment line. + logthis(' Skipping line: '. "$host\n"); + next; + } + if (!defined $hostip{$host}) { # This is a non cluster member + # The entry is of the form: + # cluname:hostname + # cluname - A 'cluster hostname' is needed in order to negotiate + # the host key. + # hostname- The dns name of the host. + # + my($cluname, $dnsname) = split(/:/, $host); + + my $ip = gethostbyname($dnsname); + if(defined($ip)) { # bad names don't deserve entry. + my $hostip = inet_ntoa($ip); + $managers{$hostip} = $cluname; + logthis(' registering manager '. + "$dnsname as $cluname with $hostip \n"); + } + } else { + logthis(' existing host'." $host\n"); + $managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber + } + } +} + # # ValidManager: Determines if a given certificate represents a valid manager. # in this primitive implementation, the 'certificate' is @@ -222,15 +2841,7 @@ sub GetCertificate { sub ValidManager { my $certificate = shift; - my $hostentry = $hostid{$certificate}; - if ($hostentry ne undef) { - &logthis('Authenticating manager'. - " $hostentry"); - return 1; - } else { - &logthis(' Failed manager authentication '. - "$certificate "); - } + return isManager; } # # CopyFile: Called as part of the process of installing a @@ -251,7 +2862,7 @@ sub CopyFile { if(-e $oldfile) { - # Read the old file. + # Read the old file. my $oldfh = IO::File->new("< $oldfile"); if(!$oldfh) { @@ -281,7 +2892,54 @@ sub CopyFile { return 0; } } - +# +# Host files are passed out with externally visible host IPs. +# If, for example, we are behind a fire-wall or NAT host, our +# internally visible IP may be different than the externally +# visible IP. Therefore, we always adjust the contents of the +# host file so that the entry for ME is the IP that we believe +# we have. At present, this is defined as the entry that +# DNS has for us. If by some chance we are not able to get a +# DNS translation for us, then we assume that the host.tab file +# is correct. +# BUGBUGBUG - in the future, we really should see if we can +# easily query the interface(s) instead. +# Parameter(s): +# contents - The contents of the host.tab to check. +# Returns: +# newcontents - The adjusted contents. +# +# +sub AdjustHostContents { + my $contents = shift; + my $adjusted; + my $me = $perlvar{'lonHostID'}; + + foreach my $line (split(/\n/,$contents)) { + if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { + chomp($line); + my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); + if ($id eq $me) { + my $ip = gethostbyname($name); + my $ipnew = inet_ntoa($ip); + $ip = $ipnew; + # Reconstruct the host line and append to adjusted: + + my $newline = "$id:$domain:$role:$name:$ip"; + if($maxcon ne "") { # Not all hosts have loncnew tuning params + $newline .= ":$maxcon:$idleto:$mincon"; + } + $adjusted .= $newline."\n"; + + } else { # Not me, pass unmodified. + $adjusted .= $line."\n"; + } + } else { # Blank or comment never re-written. + $adjusted .= $line."\n"; # Pass blanks and comments as is. + } + } + return $adjusted; +} # # InstallFile: Called to install an administrative file: # - The file is created with .tmp @@ -303,14 +2961,14 @@ sub InstallFile { my $TempFile = $Filename.".tmp"; # Open the file for write: - + my $fh = IO::File->new("> $TempFile"); # Write to temp. if(!(defined $fh)) { &logthis(' Unable to create '.$TempFile.""); return 0; } # write the contents of the file: - + print $fh ($Contents); $fh->close; # In case we ever have a filesystem w. locking @@ -322,7 +2980,31 @@ sub InstallFile { return 1; } +# +# ConfigFileFromSelector: converts a configuration file selector +# (one of host or domain at this point) into a +# configuration file pathname. +# +# Parameters: +# selector - Configuration file selector. +# Returns: +# Full path to the file or undef if the selector is invalid. +# +sub ConfigFileFromSelector { + my $selector = shift; + my $tablefile; + + my $tabledir = $perlvar{'lonTabDir'}.'/'; + if ($selector eq "hosts") { + $tablefile = $tabledir."hosts.tab"; + } elsif ($selector eq "domain") { + $tablefile = $tabledir."domain.tab"; + } else { + return undef; + } + return $tablefile; +} # # PushFile: Called to do an administrative push of a file. # - Ensure the file being pushed is one we support. @@ -352,12 +3034,9 @@ sub PushFile { # part of some elaborate spoof that managed somehow to authenticate. # - my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir. - if ($filename eq "host") { - $tablefile .= "hosts.tab"; - } elsif ($filename eq "domain") { - $tablefile .= "domain.tab"; - } else { + + my $tablefile = ConfigFileFromSelector($filename); + if(! (defined $tablefile)) { return "refused"; } # @@ -372,19 +3051,28 @@ sub PushFile { return "error:$!"; } &logthis(' Pushfile: backed up ' - .$tablefile." to $backupfile"); + .$tablefile." to $backupfile"); + # If the file being pushed is the host file, we adjust the entry for ourself so that the + # IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible + # to conceive of conditions where we don't have a DNS entry locally. This is possible in a + # network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now) + # that possibilty. + + if($filename eq "host") { + $contents = AdjustHostContents($contents); + } + # Install the new file: if(!InstallFile($tablefile, $contents)) { &logthis(' Pushfile: unable to install ' - .$tablefile." $! "); + .$tablefile." $! "); return "error:$!"; - } - else { + } else { &logthis(' Installed new '.$tablefile .""); - + } @@ -439,7 +3127,227 @@ sub ReinitProcess { } return 'ok'; } +# Validate a line in a configuration file edit script: +# Validation includes: +# - Ensuring the command is valid. +# - Ensuring the command has sufficient parameters +# Parameters: +# scriptline - A line to validate (\n has been stripped for what it's worth). +# +# Return: +# 0 - Invalid scriptline. +# 1 - Valid scriptline +# NOTE: +# Only the command syntax is checked, not the executability of the +# command. +# +sub isValidEditCommand { + my $scriptline = shift; + + # Line elements are pipe separated: + + my ($command, $key, $newline) = split(/\|/, $scriptline); + &logthis(' isValideditCommand checking: '. + "Command = '$command', Key = '$key', Newline = '$newline' \n"); + + if ($command eq "delete") { + # + # key with no newline. + # + if( ($key eq "") || ($newline ne "")) { + return 0; # Must have key but no newline. + } else { + return 1; # Valid syntax. + } + } elsif ($command eq "replace") { + # + # key and newline: + # + if (($key eq "") || ($newline eq "")) { + return 0; + } else { + return 1; + } + } elsif ($command eq "append") { + if (($key ne "") && ($newline eq "")) { + return 1; + } else { + return 0; + } + } else { + return 0; # Invalid command. + } + return 0; # Should not get here!!! +} +# +# ApplyEdit - Applies an edit command to a line in a configuration +# file. It is the caller's responsiblity to validate the +# edit line. +# Parameters: +# $directive - A single edit directive to apply. +# Edit directives are of the form: +# append|newline - Appends a new line to the file. +# replace|key|newline - Replaces the line with key value 'key' +# delete|key - Deletes the line with key value 'key'. +# $editor - A config file editor object that contains the +# file being edited. +# +sub ApplyEdit { + my $directive = shift; + my $editor = shift; + + # Break the directive down into its command and its parameters + # (at most two at this point. The meaning of the parameters, if in fact + # they exist depends on the command). + + my ($command, $p1, $p2) = split(/\|/, $directive); + + if($command eq "append") { + $editor->Append($p1); # p1 - key p2 null. + } elsif ($command eq "replace") { + $editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline. + } elsif ($command eq "delete") { + $editor->DeleteLine($p1); # p1 - key p2 null. + } else { # Should not get here!!! + die "Invalid command given to ApplyEdit $command"; + } +} +# +# AdjustOurHost: +# Adjusts a host file stored in a configuration file editor object +# for the true IP address of this host. This is necessary for hosts +# that live behind a firewall. +# Those hosts have a publicly distributed IP of the firewall, but +# internally must use their actual IP. We assume that a given +# host only has a single IP interface for now. +# Formal Parameters: +# editor - The configuration file editor to adjust. This +# editor is assumed to contain a hosts.tab file. +# Strategy: +# - Figure out our hostname. +# - Lookup the entry for this host. +# - Modify the line to contain our IP +# - Do a replace for this host. +sub AdjustOurHost { + my $editor = shift; + + # figure out who I am. + + my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname. + + # Get my host file entry. + + my $ConfigLine = $editor->Find($myHostName); + if(! (defined $ConfigLine)) { + die "AdjustOurHost - no entry for me in hosts file $myHostName"; + } + # figure out my IP: + # Use the config line to get my hostname. + # Use gethostbyname to translate that into an IP address. + # + my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine); + my $BinaryIp = gethostbyname($name); + my $ip = inet_ntoa($ip); + # + # Reassemble the config line from the elements in the list. + # Note that if the loncnew items were not present before, they will + # be now even if they would be empty + # + my $newConfigLine = $id; + foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) { + $newConfigLine .= ":".$item; + } + # Replace the line: + + $editor->ReplaceLine($id, $newConfigLine); + +} +# +# ReplaceConfigFile: +# Replaces a configuration file with the contents of a +# configuration file editor object. +# This is done by: +# - Copying the target file to .old +# - Writing the new file to .tmp +# - Moving -> +# This laborious process ensures that the system is never without +# a configuration file that's at least valid (even if the contents +# may be dated). +# Parameters: +# filename - Name of the file to modify... this is a full path. +# editor - Editor containing the file. +# +sub ReplaceConfigFile { + my $filename = shift; + my $editor = shift; + + CopyFile ($filename, $filename.".old"); + + my $contents = $editor->Get(); # Get the contents of the file. + + InstallFile($filename, $contents); +} +# +# +# Called to edit a configuration table file +# Parameters: +# request - The entire command/request sent by lonc or lonManage +# Return: +# The reply to send to the client. +# +sub EditFile { + my $request = shift; + + # Split the command into it's pieces: edit:filetype:script + + my ($request, $filetype, $script) = split(/:/, $request,3); # : in script + + # Check the pre-coditions for success: + + if($request != "edit") { # Something is amiss afoot alack. + return "error:edit request detected, but request != 'edit'\n"; + } + if( ($filetype ne "hosts") && + ($filetype ne "domain")) { + return "error:edit requested with invalid file specifier: $filetype \n"; + } + + # Split the edit script and check it's validity. + + my @scriptlines = split(/\n/, $script); # one line per element. + my $linecount = scalar(@scriptlines); + for(my $i = 0; $i < $linecount; $i++) { + chomp($scriptlines[$i]); + if(!isValidEditCommand($scriptlines[$i])) { + return "error:edit with bad script line: '$scriptlines[$i]' \n"; + } + } + + # Execute the edit operation. + # - Create a config file editor for the appropriate file and + # - execute each command in the script: + # + my $configfile = ConfigFileFromSelector($filetype); + if (!(defined $configfile)) { + return "refused\n"; + } + my $editor = ConfigFileEdit->new($configfile); + for (my $i = 0; $i < $linecount; $i++) { + ApplyEdit($scriptlines[$i], $editor); + } + # If the file is the host file, ensure that our host is + # adjusted to have our ip: + # + if($filetype eq "host") { + AdjustOurHost($editor); + } + # Finally replace the current file with our file. + # + ReplaceConfigFile($configfile, $editor); + + return "ok\n"; +} # # Convert an error return code from lcpasswd to a string value. # @@ -469,9 +3377,10 @@ sub catchexception { my ($error)=@_; $SIG{'QUIT'}='DEFAULT'; $SIG{__DIE__}='DEFAULT'; + &status("Catching exception"); &logthis("CRITICAL: " - ."ABNORMAL EXIT. Child $$ for server $thisserver died through " - ."a crash with this error msg->[$error]"); + ."ABNORMAL EXIT. Child $$ for server $thisserver died through " + ."a crash with this error msg->[$error]"); &logthis('Famous last words: '.$status.' - '.$lastlog); if ($client) { print $client "error: $error\n"; } $server->close(); @@ -479,6 +3388,7 @@ sub catchexception { } sub timeout { + &status("Handling Timeout"); &logthis("CRITICAL: TIME OUT ".$$.""); &catchexception('Timeout'); } @@ -496,11 +3406,11 @@ undef $perlvarref; # ----------------------------- Make sure this process is running from user=www my $wwwid=getpwnam('www'); if ($wwwid!=$<) { - my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; - my $subj="LON: $currenthostid User ID mismatch"; - system("echo 'User ID mismatch. lond must be run as user www.' |\ + my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; + my $subj="LON: $currenthostid User ID mismatch"; + system("echo 'User ID mismatch. lond must be run as user www.' |\ mailto $emailto -s '$subj' > /dev/null"); - exit 1; + exit 1; } # --------------------------------------------- Check if other instance running @@ -508,10 +3418,10 @@ if ($wwwid!=$<) { my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; if (-e $pidfile) { - my $lfh=IO::File->new("$pidfile"); - my $pide=<$lfh>; - chomp($pide); - if (kill 0 => $pide) { die "already running"; } + my $lfh=IO::File->new("$pidfile"); + my $pide=<$lfh>; + chomp($pide); + if (kill 0 => $pide) { die "already running"; } } # ------------------------------------------------------------- Read hosts file @@ -524,7 +3434,7 @@ $server = IO::Socket::INET->new(LocalPor Proto => 'tcp', Reuse => 1, Listen => 10 ) - or die "making socket: $@\n"; + or die "making socket: $@\n"; # --------------------------------------------------------- Do global variables @@ -535,6 +3445,7 @@ my $children = 0; # sub REAPER { # takes care of dead children $SIG{CHLD} = \&REAPER; + &status("Handling child death"); my $pid = wait; if (defined($children{$pid})) { &logthis("Child $pid died"); @@ -543,25 +3454,30 @@ sub REAPER { # ta } else { &logthis("Unknown Child $pid died"); } + &status("Finished Handling child death"); } sub HUNTSMAN { # signal handler for SIGINT + &status("Killing children (INT)"); local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children kill 'INT' => keys %children; &logthis("Free socket: ".shutdown($server,2)); # free up socket my $execdir=$perlvar{'lonDaemons'}; unlink("$execdir/logs/lond.pid"); &logthis("CRITICAL: Shutting down"); + &status("Done killing children"); exit; # clean up with dignity } sub HUPSMAN { # signal handler for SIGHUP local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children + &status("Killing children for restart (HUP)"); kill 'INT' => keys %children; &logthis("Free socket: ".shutdown($server,2)); # free up socket &logthis("CRITICAL: Restarting"); my $execdir=$perlvar{'lonDaemons'}; unlink("$execdir/logs/lond.pid"); + &status("Restarting self (HUP)"); exec("$execdir/lond"); # here we go again } @@ -623,6 +3539,7 @@ sub ReloadApache { # now be honored. # sub UpdateHosts { + &status("Reload hosts.tab"); logthis(' Updating connections '); # # The %children hash has the set of IP's we currently have children @@ -647,10 +3564,12 @@ sub UpdateHosts { } } ReloadApache; + &status("Finished reloading hosts.tab"); } sub checkchildren { + &status("Checking on the children (sending signals)"); &initnewstatus(); &logstatus(); &logthis('Going to check on the children'); @@ -665,23 +3584,25 @@ sub checkchildren { sleep 5; $SIG{ALRM} = sub { die "timeout" }; $SIG{__DIE__} = 'DEFAULT'; + &status("Checking on the children (waiting for reports)"); foreach (sort keys %children) { unless (-e "$docdir/lon-status/londchld/$_.txt") { - eval { - alarm(300); - &logthis('Child '.$_.' did not respond'); - kill 9 => $_; - #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; - #$subj="LON: $currenthostid killed lond process $_"; - #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; - #$execdir=$perlvar{'lonDaemons'}; - #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; - alarm(0); - } + eval { + alarm(300); + &logthis('Child '.$_.' did not respond'); + kill 9 => $_; + #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; + #$subj="LON: $currenthostid killed lond process $_"; + #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; + #$execdir=$perlvar{'lonDaemons'}; + #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; + alarm(0); + } } } $SIG{ALRM} = 'DEFAULT'; - $SIG{__DIE__} = \&catchcexception; + $SIG{__DIE__} = \&catchexception; + &status("Finished checking children"); } # --------------------------------------------------------------------- Logging @@ -703,20 +3624,73 @@ sub Debug { &logthis($message); } } + +# +# Sub to do replies to client.. this gives a hook for some +# debug tracing too: +# Parameters: +# fd - File open on client. +# reply - Text to send to client. +# request - Original request from client. +# +# Note: This increments Transactions +# +sub Reply { + alarm(120); + my $fd = shift; + my $reply = shift; + my $request = shift; + + print $fd $reply; + Debug("Request was $request Reply was $reply"); + + $Transactions++; + alarm(0); + + +} +# +# Sub to report a failure. +# This function: +# - Increments the failure statistic counters. +# - Invokes Reply to send the error message to the client. +# Parameters: +# fd - File descriptor open on the client +# reply - Reply text to emit. +# request - The original request message (used by Reply +# to debug if that's enabled. +# Implicit outputs: +# $Failures- The number of failures is incremented. +# Reply (invoked here) sends a message to the +# client: +# +sub Failure { + my $fd = shift; + my $reply = shift; + my $request = shift; + + $Failures++; + Reply($fd, $reply, $request); # That's simple eh? +} # ------------------------------------------------------------------ Log status sub logstatus { + &status("Doing logging"); my $docdir=$perlvar{'lonDocRoot'}; { - my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); - print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; - $fh->close(); + my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); + print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; + $fh->close(); } + &status("Finished londstatus.txt"); { my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); - print $fh $status."\n".$lastlog."\n".time; - $fh->close(); + print $fh $status."\n".$lastlog."\n".time; + $fh->close(); } + ResetStatistics; + &status("Finished logging"); + } sub initnewstatus { @@ -738,8 +3712,11 @@ sub status { my $what=shift; my $now=time; my $local=localtime($now); - $status=$local.': '.$what; - $0='lond: '.$what.' '.$local; + my $status = "lond: $what $local "; + if($Transactions) { + $status .= " Transactions: $Transactions Failed; $Failures"; + } + $0=$status; } # -------------------------------------------------------- Escape Special Chars @@ -771,12 +3748,11 @@ sub reconlonc { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; } else { - &logthis( - "CRITICAL: " - ."lonc at pid $loncpid not responding, giving up"); + &logthis("CRITICAL: " + ."lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('CRITICAL: lonc not running, giving up'); + &logthis('CRITICAL: lonc not running, giving up'); } } @@ -788,7 +3764,7 @@ sub subreply { my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10) - or return "con_lost"; + or return "con_lost"; print $sclient "$cmd\n"; my $answer=<$sclient>; chomp($answer); @@ -797,22 +3773,22 @@ sub subreply { } sub reply { - my ($cmd,$server)=@_; - my $answer; - if ($server ne $currenthostid) { - $answer=subreply($cmd,$server); - if ($answer eq 'con_lost') { - $answer=subreply("ping",$server); - if ($answer ne $server) { - &logthis("sub reply: answer != server answer is $answer, server is $server"); - &reconlonc("$perlvar{'lonSockDir'}/$server"); - } - $answer=subreply($cmd,$server); - } - } else { - $answer='self_reply'; - } - return $answer; + my ($cmd,$server)=@_; + my $answer; + if ($server ne $currenthostid) { + $answer=subreply($cmd,$server); + if ($answer eq 'con_lost') { + $answer=subreply("ping",$server); + if ($answer ne $server) { + &logthis("sub reply: answer != server answer is $answer, server is $server"); + &reconlonc("$perlvar{'lonSockDir'}/$server"); + } + $answer=subreply($cmd,$server); + } + } else { + $answer='self_reply'; + } + return $answer; } # -------------------------------------------------------------- Talk to lonsql @@ -831,7 +3807,7 @@ sub subsqlreply { my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10) - or return "con_lost"; + or return "con_lost"; print $sclient "$cmd\n"; my $answer=<$sclient>; chomp($answer); @@ -843,11 +3819,14 @@ sub subsqlreply { sub propath { my ($udom,$uname)=@_; + Debug("Propath:$udom:$uname"); $udom=~s/\W//g; $uname=~s/\W//g; + Debug("Propath2:$udom:$uname"); my $subdir=$uname.'__'; $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; + Debug("Propath returning $proname"); return $proname; } @@ -855,9 +3834,13 @@ sub propath { sub ishome { my $author=shift; + Debug("ishome: $author"); $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; + Debug(" after big regsub: $author"); my ($udom,$uname)=split(/\//,$author); + Debug(" domain: $udom user: $uname"); my $proname=propath($udom,$uname); + Debug(" path = $proname"); if (-e $proname) { return 'owner'; } else { @@ -898,28 +3881,33 @@ $SIG{USR2} = \&UpdateHosts; ReadHostTable; + # -------------------------------------------------------------- # Accept connections. When a connection comes in, it is validated # and if good, a child process is created to process transactions # along the connection. while (1) { + &status('Starting accept'); $client = $server->accept() or next; + &status('Accepted '.$client.' off to spawn'); make_new_child($client); + &status('Finished spawning'); } sub make_new_child { my $pid; - my $cipher; my $sigset; $client = shift; - &logthis("Attempting to start child"); + &status('Starting new child '.$client); + &logthis(' Attempting to start child ('.$client. + ")"); # block signal for fork $sigset = POSIX::SigSet->new(SIGINT); sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: $!\n"; - + die "fork: $!" unless defined ($pid = fork); $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of @@ -955,1274 +3943,107 @@ sub make_new_child { sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n"; - my $tmpsnum=0; -#---------------------------------------------------- kerberos 5 initialization + + &Authen::Krb5::init_context(); &Authen::Krb5::init_ets(); - - &status('Accepted connection'); + + &status('Accepted connection'); # ============================================================================= # do something with the connection # ----------------------------------------------------------------------------- # see if we know client and check for spoof IP by challenge - my $clientrec=($hostid{$clientip} ne undef); - &logthis( -"INFO: Connection, $clientip ($hostid{$clientip})" - ); - &status("Connecting $clientip ($hostid{$clientip})"); - my $clientok; - if ($clientrec) { - &status("Waiting for init from $clientip ($hostid{$clientip})"); - my $remotereq=<$client>; - $remotereq=~s/[^\w:]//g; - if ($remotereq =~ /^init/) { - &sethost("sethost:$perlvar{'lonHostID'}"); - my $challenge="$$".time; - print $client "$challenge\n"; - &status( - "Waiting for challenge reply from $clientip ($hostid{$clientip})"); - $remotereq=<$client>; - $remotereq=~s/\W//g; - if ($challenge eq $remotereq) { - $clientok=1; - print $client "ok\n"; - } else { - &logthis( - "WARNING: $clientip did not reply challenge"); - &status('No challenge reply '.$clientip); - } - } else { - &logthis( - "WARNING: " - ."$clientip failed to initialize: >$remotereq< "); - &status('No init '.$clientip); - } + ReadManagerTable; # May also be a manager!! + + my $clientrec=($hostid{$clientip} ne undef); + my $ismanager=($managers{$clientip} ne undef); + $clientname = "[unknonwn]"; + if($clientrec) { # Establish client type. + $ConnectionType = "client"; + $clientname = $hostid{$clientip}; + if($ismanager) { + $ConnectionType = "both"; + } + } else { + $ConnectionType = "manager"; + $clientname = $managers{$clientip}; + } + my $clientok; + if ($clientrec || $ismanager) { + &status("Waiting for init from $clientip $clientname"); + &logthis('INFO: Connection, '. + $clientip. + " ($clientname) connection type = $ConnectionType " ); + &status("Connecting $clientip ($clientname))"); + my $remotereq=<$client>; + $remotereq=~s/[^\w:]//g; + if ($remotereq =~ /^init/) { + &sethost("sethost:$perlvar{'lonHostID'}"); + my $challenge="$$".time; + print $client "$challenge\n"; + &status("Waiting for challenge reply from $clientip ($clientname)"); + $remotereq=<$client>; + $remotereq=~s/\W//g; + if ($challenge eq $remotereq) { + $clientok=1; + print $client "ok\n"; + } else { + &logthis("WARNING: $clientip did not reply challenge"); + &status('No challenge reply '.$clientip); + } } else { - &logthis( - "WARNING: Unknown client $clientip"); - &status('Hung up on '.$clientip); - } - if ($clientok) { + &logthis("WARNING: " + ."$clientip failed to initialize: >$remotereq< "); + &status('No init '.$clientip); + } + } else { + &logthis("WARNING: Unknown client $clientip"); + &status('Hung up on '.$clientip); + } + if ($clientok) { # ---------------- New known client connecting, could mean machine online again - - foreach my $id (keys(%hostip)) { - if ($hostip{$id} ne $clientip || - $hostip{$currenthostid} eq $clientip) { - # no need to try to do recon's to myself - next; - } - &reconlonc("$perlvar{'lonSockDir'}/$id"); + + foreach my $id (keys(%hostip)) { + if ($hostip{$id} ne $clientip || + $hostip{$currenthostid} eq $clientip) { + # no need to try to do recon's to myself + next; } - &logthis("Established connection: $hostid{$clientip}"); - &status('Will listen to '.$hostid{$clientip}); + &reconlonc("$perlvar{'lonSockDir'}/$id"); + } + &logthis("Established connection: $clientname"); + &status('Will listen to '.$clientname); + + ResetStatistics(); + # ------------------------------------------------------------ Process requests - while (my $userinput=<$client>) { - chomp($userinput); - Debug("Request = $userinput\n"); - &status('Processing '.$hostid{$clientip}.': '.$userinput); - my $wasenc=0; - alarm(120); -# ------------------------------------------------------------ See if encrypted - if ($userinput =~ /^enc/) { - if ($cipher) { - my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput); - $userinput=''; - for (my $encidx=0;$encidxdecrypt( - pack("H16",substr($encinput,$encidx,16)) - ); - } - $userinput=substr($userinput,0,$cmdlength); - $wasenc=1; - } - } - -# ------------------------------------------------------------- Normal commands -# ------------------------------------------------------------------------ ping - if ($userinput =~ /^ping/) { - print $client "$currenthostid\n"; -# ------------------------------------------------------------------------ pong - }elsif ($userinput =~ /^pong/) { - my $reply=&reply("ping",$hostid{$clientip}); - print $client "$currenthostid:$reply\n"; -# ------------------------------------------------------------------------ ekey - } elsif ($userinput =~ /^ekey/) { - my $buildkey=time.$$.int(rand 100000); - $buildkey=~tr/1-6/A-F/; - $buildkey=int(rand 100000).$buildkey.int(rand 100000); - my $key=$currenthostid.$hostid{$clientip}; - $key=~tr/a-z/A-Z/; - $key=~tr/G-P/0-9/; - $key=~tr/Q-Z/0-9/; - $key=$key.$buildkey.$key.$buildkey.$key.$buildkey; - $key=substr($key,0,32); - my $cipherkey=pack("H32",$key); - $cipher=new IDEA $cipherkey; - print $client "$buildkey\n"; -# ------------------------------------------------------------------------ load - } elsif ($userinput =~ /^load/) { - my $loadavg; - { - my $loadfile=IO::File->new('/proc/loadavg'); - $loadavg=<$loadfile>; - } - $loadavg =~ s/\s.*//g; - my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; - print $client "$loadpercent\n"; -# -------------------------------------------------------------------- userload - } elsif ($userinput =~ /^userload/) { - my $userloadpercent=&userload(); - print $client "$userloadpercent\n"; - -# -# Transactions requiring encryption: -# -# ----------------------------------------------------------------- currentauth - } elsif ($userinput =~ /^currentauth/) { - if ($wasenc==1) { - my ($cmd,$udom,$uname)=split(/:/,$userinput); - my $result = GetAuthType($udom, $uname); - if($result eq "nouser") { - print $client "unknown_user\n"; - } - else { - print $client "$result\n" - } - } else { - print $client "refused\n"; - } -#--------------------------------------------------------------------- pushfile - } elsif($userinput =~ /^pushfile/) { - if($wasenc == 1) { - my $cert = GetCertificate($userinput); - if(ValidManager($cert)) { - my $reply = PushFile($userinput); - print $client "$reply\n"; - } else { - print $client "refused\n"; - } - } else { - print $client "refused\n"; - } -#--------------------------------------------------------------------- reinit - } elsif($userinput =~ /^reinit/) { - if ($wasenc == 1) { - my $cert = GetCertificate($userinput); - if(ValidManager($cert)) { - chomp($userinput); - my $reply = ReinitProcess($userinput); - print $client "$reply\n"; - } else { - print $client "refused\n"; - } - } else { - print $client "refused\n"; - } -# ------------------------------------------------------------------------ auth - } elsif ($userinput =~ /^auth/) { - if ($wasenc==1) { - my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput); - chomp($upass); - $upass=unescape($upass); - my $proname=propath($udom,$uname); - my $passfilename="$proname/passwd"; - if (-e $passfilename) { - my $pf = IO::File->new($passfilename); - my $realpasswd=<$pf>; - chomp($realpasswd); - my ($howpwd,$contentpwd)=split(/:/,$realpasswd); - my $pwdcorrect=0; - if ($howpwd eq 'internal') { - &Debug("Internal auth"); - $pwdcorrect= - (crypt($upass,$contentpwd) eq $contentpwd); - } elsif ($howpwd eq 'unix') { - &Debug("Unix auth"); - if((getpwnam($uname))[1] eq "") { #no such user! - $pwdcorrect = 0; - } else { - $contentpwd=(getpwnam($uname))[1]; - my $pwauth_path="/usr/local/sbin/pwauth"; - unless ($contentpwd eq 'x') { - $pwdcorrect= - (crypt($upass,$contentpwd) eq - $contentpwd); - } - - elsif (-e $pwauth_path) { - open PWAUTH, "|$pwauth_path" or - die "Cannot invoke authentication"; - print PWAUTH "$uname\n$upass\n"; - close PWAUTH; - $pwdcorrect=!$?; - } - } - } elsif ($howpwd eq 'krb4') { - my $null=pack("C",0); - unless ($upass=~/$null/) { - my $krb4_error = &Authen::Krb4::get_pw_in_tkt - ($uname,"",$contentpwd,'krbtgt', - $contentpwd,1,$upass); - if (!$krb4_error) { - $pwdcorrect = 1; - } else { - $pwdcorrect=0; - # log error if it is not a bad password - if ($krb4_error != 62) { - &logthis('krb4:'.$uname.','.$contentpwd.','. - &Authen::Krb4::get_err_txt($Authen::Krb4::error)); - } - } - } - } elsif ($howpwd eq 'krb5') { - my $null=pack("C",0); - unless ($upass=~/$null/) { - my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); - my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; - my $krbserver=&Authen::Krb5::parse_name($krbservice); - my $credentials=&Authen::Krb5::cc_default(); - $credentials->initialize($krbclient); - my $krbreturn = - &Authen::Krb5::get_in_tkt_with_password( - $krbclient,$krbserver,$upass,$credentials); -# unless ($krbreturn) { -# &logthis("Krb5 Error: ". -# &Authen::Krb5::error()); -# } - $pwdcorrect = ($krbreturn == 1); - } else { $pwdcorrect=0; } - } elsif ($howpwd eq 'localauth') { - $pwdcorrect=&localauth::localauth($uname,$upass, - $contentpwd); - } - if ($pwdcorrect) { - print $client "authorized\n"; - } else { - print $client "non_authorized\n"; - } - } else { - print $client "unknown_user\n"; - } - } else { - print $client "refused\n"; - } -# ---------------------------------------------------------------------- passwd - } elsif ($userinput =~ /^passwd/) { - if ($wasenc==1) { - my - ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); - chomp($npass); - $upass=&unescape($upass); - $npass=&unescape($npass); - &Debug("Trying to change password for $uname"); - my $proname=propath($udom,$uname); - my $passfilename="$proname/passwd"; - if (-e $passfilename) { - my $realpasswd; - { my $pf = IO::File->new($passfilename); - $realpasswd=<$pf>; } - chomp($realpasswd); - my ($howpwd,$contentpwd)=split(/:/,$realpasswd); - if ($howpwd eq 'internal') { - &Debug("internal auth"); - if (crypt($upass,$contentpwd) eq $contentpwd) { - my $salt=time; - $salt=substr($salt,6,2); - my $ncpass=crypt($npass,$salt); - { - my $pf; - if ($pf = IO::File->new(">$passfilename")) { - print $pf "internal:$ncpass\n"; - &logthis("Result of password change for $uname: pwchange_success"); - print $client "ok\n"; - } else { - &logthis("Unable to open $uname passwd to change password"); - print $client "non_authorized\n"; - } - } - - } else { - print $client "non_authorized\n"; - } - } elsif ($howpwd eq 'unix') { - # Unix means we have to access /etc/password - # one way or another. - # First: Make sure the current password is - # correct - &Debug("auth is unix"); - $contentpwd=(getpwnam($uname))[1]; - my $pwdcorrect = "0"; - my $pwauth_path="/usr/local/sbin/pwauth"; - unless ($contentpwd eq 'x') { - $pwdcorrect= - (crypt($upass,$contentpwd) eq $contentpwd); - } elsif (-e $pwauth_path) { - open PWAUTH, "|$pwauth_path" or - die "Cannot invoke authentication"; - print PWAUTH "$uname\n$upass\n"; - close PWAUTH; - &Debug("exited pwauth with $? ($uname,$upass) "); - $pwdcorrect=($? == 0); - } - if ($pwdcorrect) { - 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: ". - &lcpasswdstrerror($?)); - print $client "$result\n"; - } else { - print $client "non_authorized\n"; - } - } else { - print $client "auth_mode_error\n"; - } - } else { - print $client "unknown_user\n"; - } - } else { - print $client "refused\n"; - } -# -------------------------------------------------------------------- makeuser - } elsif ($userinput =~ /^makeuser/) { - &Debug("Make user received"); - my $oldumask=umask(0077); - if ($wasenc==1) { - my - ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); - &Debug("cmd =".$cmd." $udom =".$udom. - " uname=".$uname); - chomp($npass); - $npass=&unescape($npass); - my $proname=propath($udom,$uname); - my $passfilename="$proname/passwd"; - &Debug("Password file created will be:". - $passfilename); - if (-e $passfilename) { - print $client "already_exists\n"; - } elsif ($udom ne $currentdomainid) { - print $client "not_right_domain\n"; - } else { - my @fpparts=split(/\//,$proname); - my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; - my $fperror=''; - for (my $i=3;$i<=$#fpparts;$i++) { - $fpnow.='/'.$fpparts[$i]; - unless (-e $fpnow) { - unless (mkdir($fpnow,0777)) { - $fperror="error: ".($!+0) - ." mkdir failed while attempting " - ."makeuser\n"; - } - } - } - unless ($fperror) { - my $result=&make_passwd_file($uname, $umode,$npass, - $passfilename); - print $client $result; - } else { - print $client "$fperror\n"; - } - } - } else { - print $client "refused\n"; - } - umask($oldumask); -# -------------------------------------------------------------- changeuserauth - } elsif ($userinput =~ /^changeuserauth/) { - &Debug("Changing authorization"); - if ($wasenc==1) { - my - ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); - chomp($npass); - &Debug("cmd = ".$cmd." domain= ".$udom. - "uname =".$uname." umode= ".$umode); - $npass=&unescape($npass); - my $proname=&propath($udom,$uname); - my $passfilename="$proname/passwd"; - if ($udom ne $currentdomainid) { - print $client "not_right_domain\n"; - } else { - my $result=&make_passwd_file($uname, $umode,$npass, - $passfilename); - print $client $result; - } - } else { - print $client "refused\n"; - } -# ------------------------------------------------------------------------ home - } elsif ($userinput =~ /^home/) { - my ($cmd,$udom,$uname)=split(/:/,$userinput); - chomp($uname); - my $proname=propath($udom,$uname); - if (-e $proname) { - print $client "found\n"; - } else { - print $client "not_found\n"; - } -# ---------------------------------------------------------------------- update - } elsif ($userinput =~ /^update/) { - my ($cmd,$fname)=split(/:/,$userinput); - my $ownership=ishome($fname); - if ($ownership eq 'not_owner') { - if (-e $fname) { - my ($dev,$ino,$mode,$nlink, - $uid,$gid,$rdev,$size, - $atime,$mtime,$ctime, - $blksize,$blocks)=stat($fname); - my $now=time; - my $since=$now-$atime; - if ($since>$perlvar{'lonExpire'}) { - my $reply= - &reply("unsub:$fname","$hostid{$clientip}"); - unlink("$fname"); - } else { - my $transname="$fname.in.transfer"; - my $remoteurl= - reply("sub:$fname","$hostid{$clientip}"); - my $response; - { - my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',"$remoteurl"); - $response=$ua->request($request,$transname); - } - if ($response->is_error()) { - unlink($transname); - my $message=$response->status_line; - &logthis( - "LWP GET: $message for $fname ($remoteurl)"); - } else { - if ($remoteurl!~/\.meta$/) { - my $ua=new LWP::UserAgent; - my $mrequest= - new HTTP::Request('GET',$remoteurl.'.meta'); - my $mresponse= - $ua->request($mrequest,$fname.'.meta'); - if ($mresponse->is_error()) { - unlink($fname.'.meta'); - } - } - rename($transname,$fname); - } - } - print $client "ok\n"; - } else { - print $client "not_found\n"; - } - } else { - print $client "rejected\n"; - } -# -------------------------------------- fetch a user file from a remote server - } elsif ($userinput =~ /^fetchuserfile/) { - my ($cmd,$fname)=split(/:/,$userinput); - my ($udom,$uname,$ufile)=split(/\//,$fname); - my $udir=propath($udom,$uname).'/userfiles'; - unless (-e $udir) { mkdir($udir,0770); } - if (-e $udir) { - $ufile=~s/^[\.\~]+//; - $ufile=~s/\///g; - my $destname=$udir.'/'.$ufile; - my $transname=$udir.'/'.$ufile.'.in.transit'; - my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; - my $response; - { - my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',"$remoteurl"); - $response=$ua->request($request,$transname); - } - if ($response->is_error()) { - unlink($transname); - my $message=$response->status_line; - &logthis("LWP GET: $message for $fname ($remoteurl)"); - print $client "failed\n"; - } else { - if (!rename($transname,$destname)) { - &logthis("Unable to move $transname to $destname"); - unlink($transname); - print $client "failed\n"; - } else { - print $client "ok\n"; - } - } - } else { - print $client "not_home\n"; - } -# ------------------------------------------ authenticate access to a user file - } elsif ($userinput =~ /^tokenauthuserfile/) { - my ($cmd,$fname,$session)=split(/:/,$userinput); - chomp($session); - my $reply='non_auth'; - if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. - $session.'.id')) { - while (my $line=) { - if ($line=~/userfile\.$fname\=/) { $reply='ok'; } - } - close(ENVIN); - print $client $reply."\n"; - } else { - print $client "invalid_token\n"; - } -# ----------------------------------------------------------------- unsubscribe - } elsif ($userinput =~ /^unsub/) { - my ($cmd,$fname)=split(/:/,$userinput); - if (-e $fname) { - print $client &unsub($client,$fname,$clientip); - } else { - print $client "not_found\n"; - } -# ------------------------------------------------------------------- subscribe - } elsif ($userinput =~ /^sub/) { - print $client &subscribe($userinput,$clientip); -# ------------------------------------------------------------- current version - } elsif ($userinput =~ /^currentversion/) { - my ($cmd,$fname)=split(/:/,$userinput); - print $client ¤tversion($fname)."\n"; -# ------------------------------------------------------------------------- log - } elsif ($userinput =~ /^log/) { - my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); - chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - { - my $hfh; - if ($hfh=IO::File->new(">>$proname/activity.log")) { - print $hfh "$now:$hostid{$clientip}:$what\n"; - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." IO::File->new Failed " - ."while attempting log\n"; - } - } -# ------------------------------------------------------------------------- put - } elsif ($userinput =~ /^put/) { - my ($cmd,$udom,$uname,$namespace,$what) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - if ($namespace ne 'roles') { - chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - unless ($namespace=~/^nohist\_/) { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname/$namespace.hist") - ) { print $hfh "P:$now:$what\n"; } - } - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { - foreach my $pair (@pairs) { - my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) failed ". - "while attempting put\n"; - } - } else { - print $client "error: ".($!) - ." tie(GDBM) Failed ". - "while attempting put\n"; - } - } else { - print $client "refused\n"; - } -# -------------------------------------------------------------------- rolesput - } elsif ($userinput =~ /^rolesput/) { - &Debug("rolesput"); - if ($wasenc==1) { - my ($cmd,$exedom,$exeuser,$udom,$uname,$what) - =split(/:/,$userinput); - &Debug("cmd = ".$cmd." exedom= ".$exedom. - "user = ".$exeuser." udom=".$udom. - "what = ".$what); - my $namespace='roles'; - chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname/$namespace.hist") - ) { - print $hfh "P:$now:$exedom:$exeuser:$what\n"; - } - } - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { - foreach my $pair (@pairs) { - my ($key,$value)=split(/=/,$pair); - &ManagePermissions($key, $udom, $uname, - &GetAuthType( $udom, - $uname)); - $hash{$key}=$value; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting rolesput\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting rolesput\n"; - } - } else { - print $client "refused\n"; - } -# -------------------------------------------------------------------- rolesdel - } elsif ($userinput =~ /^rolesdel/) { - &Debug("rolesdel"); - if ($wasenc==1) { - my ($cmd,$exedom,$exeuser,$udom,$uname,$what) - =split(/:/,$userinput); - &Debug("cmd = ".$cmd." exedom= ".$exedom. - "user = ".$exeuser." udom=".$udom. - "what = ".$what); - my $namespace='roles'; - chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname/$namespace.hist") - ) { - print $hfh "D:$now:$exedom:$exeuser:$what\n"; - } - } - my @rolekeys=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { - foreach my $key (@rolekeys) { - delete $hash{$key}; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting rolesdel\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting rolesdel\n"; - } - } else { - print $client "refused\n"; - } -# ------------------------------------------------------------------------- get - } elsif ($userinput =~ /^get/) { - my ($cmd,$udom,$uname,$namespace,$what) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - chomp($what); - my @queries=split(/\&/,$what); - my $proname=propath($udom,$uname); - my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { - for (my $i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting get\n"; - } - } else { - if ($!+0 == 2) { - print $client "error:No such file or ". - "GDBM reported bad block error\n"; - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting get\n"; - } - } -# ------------------------------------------------------------------------ eget - } elsif ($userinput =~ /^eget/) { - my ($cmd,$udom,$uname,$namespace,$what) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - chomp($what); - my @queries=split(/\&/,$what); - my $proname=propath($udom,$uname); - my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { - for (my $i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - if ($cipher) { - my $cmdlength=length($qresult); - $qresult.=" "; - my $encqresult=''; - for - (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { - $encqresult.= - unpack("H16", - $cipher->encrypt(substr($qresult,$encidx,8))); - } - print $client "enc:$cmdlength:$encqresult\n"; - } else { - print $client "error:no_key\n"; - } - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting eget\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting eget\n"; - } -# ------------------------------------------------------------------------- del - } elsif ($userinput =~ /^del/) { - my ($cmd,$udom,$uname,$namespace,$what) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - unless ($namespace=~/^nohist\_/) { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname/$namespace.hist") - ) { print $hfh "D:$now:$what\n"; } - } - my @keys=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { - foreach my $key (@keys) { - delete($hash{$key}); - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting del\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting del\n"; - } -# ------------------------------------------------------------------------ keys - } elsif ($userinput =~ /^keys/) { - my ($cmd,$udom,$uname,$namespace) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - my $proname=propath($udom,$uname); - my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { - foreach my $key (keys %hash) { - $qresult.="$key&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting keys\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting keys\n"; - } -# ----------------------------------------------------------------- dumpcurrent - } elsif ($userinput =~ /^currentdump/) { - my ($cmd,$udom,$uname,$namespace) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - my $qresult=''; - my $proname=propath($udom,$uname); - my %hash; - if (tie(%hash,'GDBM_File', - "$proname/$namespace.db", - &GDBM_READER(),0640)) { - # Structure of %data: - # $data{$symb}->{$parameter}=$value; - # $data{$symb}->{'v.'.$parameter}=$version; - # since $parameter will be unescaped, we do not - # have to worry about silly parameter names... - my %data = (); - while (my ($key,$value) = each(%hash)) { - my ($v,$symb,$param) = split(/:/,$key); - next if ($v eq 'version' || $symb eq 'keys'); - next if (exists($data{$symb}) && - exists($data{$symb}->{$param}) && - $data{$symb}->{'v.'.$param} > $v); - $data{$symb}->{$param}=$value; - $data{$symb}->{'v.'.$param}=$v; - } - if (untie(%hash)) { - while (my ($symb,$param_hash) = each(%data)) { - while(my ($param,$value) = each (%$param_hash)){ - next if ($param =~ /^v\./); - $qresult.=$symb.':'.$param.'='.$value.'&'; - } - } - chop($qresult); - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting currentdump\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting currentdump\n"; - } -# ------------------------------------------------------------------------ dump - } elsif ($userinput =~ /^dump/) { - my ($cmd,$udom,$uname,$namespace,$regexp) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - if (defined($regexp)) { - $regexp=&unescape($regexp); - } else { - $regexp='.'; - } - my $qresult=''; - my $proname=propath($udom,$uname); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { - study($regexp); - while (my ($key,$value) = each(%hash)) { - if ($regexp eq '.') { - $qresult.=$key.'='.$value.'&'; - } else { - my $unescapeKey = &unescape($key); - if (eval('$unescapeKey=~/$regexp/')) { - $qresult.="$key=$value&"; - } - } - } - if (untie(%hash)) { - chop($qresult); - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting dump\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting dump\n"; - } -# ----------------------------------------------------------------------- store - } elsif ($userinput =~ /^store/) { - my ($cmd,$udom,$uname,$namespace,$rid,$what) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - if ($namespace ne 'roles') { - chomp($what); - my $proname=propath($udom,$uname); - my $now=time; - unless ($namespace=~/^nohist\_/) { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname/$namespace.hist") - ) { print $hfh "P:$now:$rid:$what\n"; } - } - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { - my @previouskeys=split(/&/,$hash{"keys:$rid"}); - my $key; - $hash{"version:$rid"}++; - my $version=$hash{"version:$rid"}; - my $allkeys=''; - foreach my $pair (@pairs) { - my ($key,$value)=split(/=/,$pair); - $allkeys.=$key.':'; - $hash{"$version:$rid:$key"}=$value; - } - $hash{"$version:$rid:timestamp"}=$now; - $allkeys.='timestamp'; - $hash{"$version:keys:$rid"}=$allkeys; - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting store\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting store\n"; - } - } else { - print $client "refused\n"; - } -# --------------------------------------------------------------------- restore - } elsif ($userinput =~ /^restore/) { - my ($cmd,$udom,$uname,$namespace,$rid) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - chomp($rid); - my $proname=propath($udom,$uname); - my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { - my $version=$hash{"version:$rid"}; - $qresult.="version=$version&"; - my $scope; - for ($scope=1;$scope<=$version;$scope++) { - my $vkeys=$hash{"$scope:keys:$rid"}; - my @keys=split(/:/,$vkeys); - my $key; - $qresult.="$scope:keys=$vkeys&"; - foreach $key (@keys) { - $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; - } - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting restore\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting restore\n"; - } -# -------------------------------------------------------------------- chatsend - } elsif ($userinput =~ /^chatsend/) { - my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); - &chatadd($cdom,$cnum,$newpost); - print $client "ok\n"; -# -------------------------------------------------------------------- chatretr - } elsif ($userinput =~ /^chatretr/) { - my - ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); - my $reply=''; - foreach (&getchat($cdom,$cnum,$udom,$uname)) { - $reply.=&escape($_).':'; - } - $reply=~s/\:$//; - print $client $reply."\n"; -# ------------------------------------------------------------------- querysend - } elsif ($userinput =~ /^querysend/) { - my ($cmd,$query, - $arg1,$arg2,$arg3)=split(/\:/,$userinput); - $query=~s/\n*$//g; - print $client "". - sqlreply("$hostid{$clientip}\&$query". - "\&$arg1"."\&$arg2"."\&$arg3")."\n"; -# ------------------------------------------------------------------ queryreply - } elsif ($userinput =~ /^queryreply/) { - my ($cmd,$id,$reply)=split(/:/,$userinput); - my $store; - my $execdir=$perlvar{'lonDaemons'}; - if ($store=IO::File->new(">$execdir/tmp/$id")) { - $reply=~s/\&/\n/g; - print $store $reply; - close $store; - my $store2=IO::File->new(">$execdir/tmp/$id.end"); - print $store2 "done\n"; - close $store2; - print $client "ok\n"; - } - else { - print $client "error: ".($!+0) - ." IO::File->new Failed ". - "while attempting queryreply\n"; - } -# ----------------------------------------------------------------- courseidput - } elsif ($userinput =~ /^courseidput/) { - my ($cmd,$udom,$what)=split(/:/,$userinput); - chomp($what); - $udom=~s/\W//g; - my $proname= - "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; - my $now=time; - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { - foreach my $pair (@pairs) { - my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value.':'.$now; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting courseidput\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting courseidput\n"; - } -# ---------------------------------------------------------------- courseiddump - } elsif ($userinput =~ /^courseiddump/) { - my ($cmd,$udom,$since,$description) - =split(/:/,$userinput); - if (defined($description)) { - $description=&unescape($description); - } else { - $description='.'; - } - unless (defined($since)) { $since=0; } - my $qresult=''; - my $proname= - "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { - while (my ($key,$value) = each(%hash)) { - my ($descr,$lasttime)=split(/\:/,$value); - if ($lasttime<$since) { next; } - if ($description eq '.') { - $qresult.=$key.'='.$descr.'&'; - } else { - my $unescapeVal = &unescape($descr); - if (eval('$unescapeVal=~/$description/i')) { - $qresult.="$key=$descr&"; - } - } - } - if (untie(%hash)) { - chop($qresult); - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting courseiddump\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting courseiddump\n"; - } -# ----------------------------------------------------------------------- idput - } elsif ($userinput =~ /^idput/) { - my ($cmd,$udom,$what)=split(/:/,$userinput); - chomp($what); - $udom=~s/\W//g; - my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; - my $now=time; - { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname.hist") - ) { print $hfh "P:$now:$what\n"; } - } - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { - foreach my $pair (@pairs) { - my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting idput\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting idput\n"; - } -# ----------------------------------------------------------------------- idget - } elsif ($userinput =~ /^idget/) { - my ($cmd,$udom,$what)=split(/:/,$userinput); - chomp($what); - $udom=~s/\W//g; - my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; - my @queries=split(/\&/,$what); - my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { - for (my $i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting idget\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting idget\n"; - } -# ---------------------------------------------------------------------- tmpput - } elsif ($userinput =~ /^tmpput/) { - my ($cmd,$what)=split(/:/,$userinput); - my $store; - $tmpsnum++; - my $id=$$.'_'.$clientip.'_'.$tmpsnum; - $id=~s/\W/\_/g; - $what=~s/\n//g; - my $execdir=$perlvar{'lonDaemons'}; - if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { - print $store $what; - close $store; - print $client "$id\n"; - } - else { - print $client "error: ".($!+0) - ."IO::File->new Failed ". - "while attempting tmpput\n"; - } - -# ---------------------------------------------------------------------- tmpget - } elsif ($userinput =~ /^tmpget/) { - my ($cmd,$id)=split(/:/,$userinput); - chomp($id); - $id=~s/\W/\_/g; - my $store; - my $execdir=$perlvar{'lonDaemons'}; - if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { - my $reply=<$store>; - print $client "$reply\n"; - close $store; - } - else { - print $client "error: ".($!+0) - ."IO::File->new Failed ". - "while attempting tmpget\n"; - } - -# ---------------------------------------------------------------------- tmpdel - } elsif ($userinput =~ /^tmpdel/) { - my ($cmd,$id)=split(/:/,$userinput); - chomp($id); - $id=~s/\W/\_/g; - my $execdir=$perlvar{'lonDaemons'}; - if (unlink("$execdir/tmp/$id.tmp")) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ."Unlink tmp Failed ". - "while attempting tmpdel\n"; - } -# -------------------------------------------------------------------------- ls - } elsif ($userinput =~ /^ls/) { - my ($cmd,$ulsdir)=split(/:/,$userinput); - my $ulsout=''; - my $ulsfn; - if (-e $ulsdir) { - if(-d $ulsdir) { - if (opendir(LSDIR,$ulsdir)) { - while ($ulsfn=readdir(LSDIR)) { - my @ulsstats=stat($ulsdir.'/'.$ulsfn); - $ulsout.=$ulsfn.'&'. - join('&',@ulsstats).':'; - } - closedir(LSDIR); - } - } else { - my @ulsstats=stat($ulsdir); - $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; - } - } else { - $ulsout='no_such_dir'; - } - if ($ulsout eq '') { $ulsout='empty'; } - print $client "$ulsout\n"; -# ----------------------------------------------------------------- setannounce - } elsif ($userinput =~ /^setannounce/) { - my ($cmd,$announcement)=split(/:/,$userinput); - chomp($announcement); - $announcement=&unescape($announcement); - if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. - '/announcement.txt')) { - print $store $announcement; - close $store; - print $client "ok\n"; - } else { - print $client "error: ".($!+0)."\n"; - } -# ------------------------------------------------------------------ Hanging up - } elsif (($userinput =~ /^exit/) || - ($userinput =~ /^init/)) { - &logthis( - "Client $clientip ($hostid{$clientip}) hanging up: $userinput"); - print $client "bye\n"; - $client->close(); - last; -# ------------------------------------------------------------- unknown command - } elsif ($userinput =~ /^sethost:/) { - print $client &sethost($userinput)."\n"; - } elsif ($userinput =~/^version:/) { - print $client &version($userinput)."\n"; - } else { - # unknown command - print $client "unknown_cmd\n"; - } + my $KeepGoing = 1; + while ((my $userinput=GetRequest) && $KeepGoing) { + $KeepGoing = ProcessRequest($userinput); # -------------------------------------------------------------------- complete - alarm(0); - &status('Listening to '.$hostid{$clientip}); - } -# --------------------------------------------- client unknown or fishy, refuse - } else { - print $client "refused\n"; - $client->close(); - &logthis("WARNING: " - ."Rejected client $clientip, closing connection"); - } - } + &status('Listening to '.$clientname); + } +# --------------------------------------------- client unknown or fishy, refuse + } else { + print $client "refused\n"; + $client->close(); + &logthis("WARNING: " + ."Rejected client $clientip, closing connection"); + } + } + # ============================================================================= - - &logthis("CRITICAL: " - ."Disconnect from $clientip ($hostid{$clientip})"); - - - # this exit is VERY important, otherwise the child will become - # a producer of more and more children, forking yourself into - # process death. - exit; + + &logthis("CRITICAL: " + ."Disconnect from $clientip ($clientname)"); + + + # this exit is VERY important, otherwise the child will become + # a producer of more and more children, forking yourself into + # process death. + exit; } @@ -2238,15 +4059,14 @@ sub make_new_child { # user - Name of the user for which the role is being put. # authtype - The authentication type associated with the user. # -sub ManagePermissions -{ +sub ManagePermissions { my $request = shift; my $domain = shift; my $user = shift; my $authtype= shift; # See if the request is of the form /$domain/_au - &logthis("ruequest is $request"); + &logthis("request is $request"); if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... my $execdir = $perlvar{'lonDaemons'}; my $userhome= "/home/$user" ; @@ -2254,39 +4074,231 @@ sub ManagePermissions system("$execdir/lchtmldir $userhome $user $authtype"); } } + +# +# Return the full path of a user password file, whether it exists or not. +# Parameters: +# domain - Domain in which the password file lives. +# user - name of the user. +# Returns: +# Full passwd path: +# +sub PasswordPath { + my $domain = shift; + my $user = shift; + + my $path = &propath($domain, $user); + $path .= "/passwd"; + + return $path; +} + +# Password Filename +# Returns the path to a passwd file given domain and user... only if +# it exists. +# Parameters: +# domain - Domain in which to search. +# user - username. +# Returns: +# - If the password file exists returns its path. +# - If the password file does not exist, returns undefined. +# +sub PasswordFilename { + my $domain = shift; + my $user = shift; + + Debug ("PasswordFilename called: dom = $domain user = $user"); + + my $path = PasswordPath($domain, $user); + Debug("PasswordFilename got path: $path"); + if(-e $path) { + return $path; + } else { + return undef; + } +} + +# +# Rewrite the contents of the user's passwd file. +# Parameters: +# domain - domain of the user. +# name - User's name. +# contents - New contents of the file. +# Returns: +# 0 - Failed. +# 1 - Success. +# +sub RewritePwFile { + my $domain = shift; + my $user = shift; + my $contents = shift; + + my $file = PasswordFilename($domain, $user); + if (defined $file) { + my $pf = IO::File->new(">$file"); + if($pf) { + print $pf "$contents\n"; + return 1; + } else { + return 0; + } + } else { + return 0; + } + +} # # GetAuthType - Determines the authorization type of a user in a domain. # Returns the authorization type or nouser if there is no such user. # -sub GetAuthType -{ +sub GetAuthType { my $domain = shift; my $user = shift; Debug("GetAuthType( $domain, $user ) \n"); - my $proname = &propath($domain, $user); - my $passwdfile = "$proname/passwd"; - if( -e $passwdfile ) { + my $passwdfile = PasswordFilename($domain, $user); + if( defined $passwdfile ) { my $pf = IO::File->new($passwdfile); my $realpassword = <$pf>; chomp($realpassword); Debug("Password info = $realpassword\n"); - my ($authtype, $contentpwd) = split(/:/, $realpassword); - Debug("Authtype = $authtype, content = $contentpwd\n"); - my $availinfo = ''; - if($authtype eq 'krb4' or $authtype eq 'krb5') { - $availinfo = $contentpwd; - } - - return "$authtype:$availinfo"; - } - else { + return $realpassword; + } else { Debug("Returning nouser"); return "nouser"; } } +# +# Validate a user given their domain, name and password. This utility +# function is used by both AuthenticateHandler and ChangePasswordHandler +# to validate the login credentials of a user. +# Parameters: +# $domain - The domain being logged into (this is required due to +# the capability for multihomed systems. +# $user - The name of the user being validated. +# $password - The user's propoposed password. +# +# Returns: +# 1 - The domain,user,pasword triplet corresponds to a valid +# user. +# 0 - The domain,user,password triplet is not a valid user. +# +sub ValidateUser { + my $domain = shift; + my $user = shift; + my $password= shift; + + # Why negative ~pi you may well ask? Well this function is about + # authentication, and therefore very important to get right. + # I've initialized the flag that determines whether or not I've + # validated correctly to a value it's not supposed to get. + # At the end of this function. I'll ensure that it's not still that + # value so we don't just wind up returning some accidental value + # as a result of executing an unforseen code path that + # did not set $validated. + + my $validated = -3.14159; + + # How we authenticate is determined by the type of authentication + # the user has been assigned. If the authentication type is + # "nouser", the user does not exist so we will return 0. + + my $contents = GetAuthType($domain, $user); + my ($howpwd, $contentpwd) = split(/:/, $contents); + + my $null = pack("C",0); # Used by kerberos auth types. + + if ($howpwd ne 'nouser') { + + if($howpwd eq "internal") { # Encrypted is in local password file. + $validated = (crypt($password, $contentpwd) eq $contentpwd); + } + elsif ($howpwd eq "unix") { # User is a normal unix user. + $contentpwd = (getpwnam($user))[1]; + if($contentpwd) { + if($contentpwd eq 'x') { # Shadow password file... + my $pwauth_path = "/usr/local/sbin/pwauth"; + open PWAUTH, "|$pwauth_path" or + die "Cannot invoke authentication"; + print PWAUTH "$user\n$password\n"; + close PWAUTH; + $validated = ! $?; + + } else { # Passwords in /etc/passwd. + $validated = (crypt($password, + $contentpwd) eq $contentpwd); + } + } else { + $validated = 0; + } + } + elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain. + if(! ($password =~ /$null/) ) { + my $k4error = &Authen::Krb4::get_pw_in_tkt($user, + "", + $contentpwd,, + 'krbtgt', + $contentpwd, + 1, + $password); + if(!$k4error) { + $validated = 1; + } + else { + $validated = 0; + &logthis('krb4: '.$user.', '.$contentpwd.', '. + &Authen::Krb4::get_err_txt($Authen::Krb4::error)); + } + } + else { + $validated = 0; # Password has a match with null. + } + } + elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain. + if(!($password =~ /$null/)) { # Null password not allowed. + my $krbclient = &Authen::Krb5::parse_name($user.'@' + .$contentpwd); + my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd; + my $krbserver = &Authen::Krb5::parse_name($krbservice); + my $credentials= &Authen::Krb5::cc_default(); + $credentials->initialize($krbclient); + my $krbreturn = &Authen::KRb5::get_in_tkt_with_password($krbclient, + $krbserver, + $password, + $credentials); + $validated = ($krbreturn == 1); + } + else { + $validated = 0; + } + } + elsif ($howpwd eq "localauth") { + # Authenticate via installation specific authentcation method: + $validated = &localauth::localauth($user, + $password, + $contentpwd); + } + else { # Unrecognized auth is also bad. + $validated = 0; + } + } else { + $validated = 0; + } + # + # $validated has the correct stat of the authentication: + # + + unless ($validated != -3.14159) { + die "ValidateUser - failed to set the value of validated"; + } + return $validated; +} + +# +# Add a line to the subscription list? +# sub addline { my ($fname,$hostid,$ip,$newline)=@_; my $contents; @@ -2294,19 +4306,31 @@ sub addline { my $expr='^'.$hostid.':'.$ip.':'; $expr =~ s/\./\\\./g; my $sh; + Debug("Looking for $expr"); if ($sh=IO::File->new("$fname.subscription")) { while (my $subline=<$sh>) { - if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} + Debug("addline: line: $subline"); + if ($subline !~ /$expr/) { + $contents.= $subline; + } else { + Debug("Found $subline"); + $found=1; + } } $sh->close(); } $sh=IO::File->new(">$fname.subscription"); if ($contents) { print $sh $contents; } - if ($newline) { print $sh $newline; } + if ($newline) { + Debug("Appending $newline"); + print $sh $newline; + } $sh->close(); return $found; } - +# +# Get chat messages. +# sub getchat { my ($cdom,$cname,$udom,$uname)=@_; my %hash; @@ -2331,7 +4355,9 @@ sub getchat { } return (@participants,@entries); } - +# +# Add a chat message +# sub chatadd { my ($cdom,$cname,$newchat)=@_; my %hash; @@ -2371,17 +4397,36 @@ sub chatadd { sub unsub { my ($fname,$clientip)=@_; my $result; - if (unlink("$fname.$hostid{$clientip}")) { - $result="ok\n"; - } else { - $result="not_subscribed\n"; - } + my $unsubs = 0; # Number of successful unsubscribes: + + + # An old way subscriptions were handled was to have a + # subscription marker file: + + Debug("Attempting unlink of $fname.$clientname"); + if (unlink("$fname.$clientname")) { + $unsubs++; # Successful unsub via marker file. + } + + # The more modern way to do it is to have a subscription list + # file: + if (-e "$fname.subscription") { - my $found=&addline($fname,$hostid{$clientip},$clientip,''); - if ($found) { $result="ok\n"; } + my $found=&addline($fname,$clientname,$clientip,''); + if ($found) { + $unsubs++; + } + } + + # If either or both of these mechanisms succeeded in unsubscribing a + # resource we can return ok: + + if($unsubs) { + $result = "ok\n"; } else { - if ($result != "ok\n") { $result="not_subscribed\n"; } + $result = "not_subscribed\n"; } + return $result; } @@ -2390,7 +4435,7 @@ sub currentversion { my $version=-1; my $ulsdir=''; if ($fname=~/^(.+)\/[^\/]+$/) { - $ulsdir=$1; + $ulsdir=$1; } my ($fnamere1,$fnamere2); # remove version if already specified @@ -2409,7 +4454,7 @@ sub currentversion { # see if this is a regular file (ignore links produced earlier) my $thisfile=$ulsdir.'/'.$ulsfn; unless (-l $thisfile) { - if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) { + if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) { if ($1>$version) { $version=$1; } } } @@ -2433,12 +4478,15 @@ sub thisversion { sub subscribe { my ($userinput,$clientip)=@_; + chomp($userinput); my $result; my ($cmd,$fname)=split(/:/,$userinput); my $ownership=&ishome($fname); + Debug("subscribe: Owner = $ownership file: '$fname'"); if ($ownership eq 'owner') { # explitly asking for the current version? unless (-e $fname) { + Debug("subscribe - does not exist"); my $currentversion=¤tversion($fname); if (&thisversion($fname)==$currentversion) { if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { @@ -2447,20 +4495,21 @@ sub subscribe { symlink($root.'.'.$extension, $root.'.'.$currentversion.'.'.$extension); unless ($extension=~/\.meta$/) { - symlink($root.'.'.$extension.'.meta', - $root.'.'.$currentversion.'.'.$extension.'.meta'); + symlink($root.'.'.$extension.'.meta', + $root.'.'.$currentversion.'.'.$extension.'.meta'); } } } } if (-e $fname) { + Debug("subscribe - exists"); if (-d $fname) { $result="directory\n"; } else { - if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} + if (-e "$fname.$clientname") {&unsub($fname,$clientip);} my $now=time; - my $found=&addline($fname,$hostid{$clientip},$clientip, - "$hostid{$clientip}:$clientip:$now\n"); + my $found=&addline($fname,$clientname,$clientip, + "$clientname:$clientip:$now\n"); if ($found) { $result="$fname\n"; } # if they were subscribed to only meta data, delete that # subscription, when you subscribe to a file you also get @@ -2502,23 +4551,35 @@ sub make_passwd_file { print $pf "localauth:$npass\n"; } } elsif ($umode eq 'unix') { - { - my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; - { - &Debug("Executing external: ".$execpath); - &Debug("user = ".$uname.", Password =". $npass); - my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); - print $se "$uname\n"; - print $se "$npass\n"; - print $se "$npass\n"; - } - my $useraddok = $?; - if($useraddok > 0) { - &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); - } - my $pf = IO::File->new(">$passfilename"); - print $pf "unix:\n"; + # + # Don't allow the creation of privileged accounts!!! that would + # be real bad!!! + # + my $uid = getpwnam($uname); + if((defined $uid) && ($uid == 0)) { + &logthis(">>>Attempted add of privileged account blocked<<<"); + return "no_priv_account_error\n"; + } + + # + my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; + + &Debug("Executing external: ".$execpath); + &Debug("user = ".$uname.", Password =". $npass); + my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); + print $se "$uname\n"; + print $se "$npass\n"; + print $se "$npass\n"; + + my $useraddok = $?; + if($useraddok > 0) { + my $lcstring = lcuseraddstrerror($useraddok); + &logthis("Failed lcuseradd: $lcstring"); + return "error: lcuseradd failed: $lcstring\n"; } + my $pf = IO::File->new(">$passfilename"); + print $pf "unix:\n"; + } elsif ($umode eq 'none') { { my $pf = IO::File->new(">$passfilename"); @@ -2532,8 +4593,10 @@ sub make_passwd_file { sub sethost { my ($remotereq) = @_; + Debug("sethost got $remotereq"); my (undef,$hostid)=split(/:/,$remotereq); if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } + Debug("sethost attempting to set host $hostid"); if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { $currenthostid=$hostid; $currentdomainid=$hostdom{$hostid}; @@ -2551,8 +4614,10 @@ sub version { $remoteVERSION=(split(/:/,$userinput))[1]; return "version:$VERSION"; } - +############## >>>>>>>>>>>>>>>>>>>>>>>>>> FUTUREWORK <<<<<<<<<<<<<<<<<<<<<<<<<<<< #There is a copy of this in lonnet.pm +# Can we hoist these lil' things out into common places? +# sub userload { my $numusers=0; { @@ -2562,7 +4627,7 @@ sub userload { while ($filename=readdir(LONIDS)) { if ($filename eq '.' || $filename eq '..') {next;} my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; - if ($curtime-$mtime < 3600) { $numusers++; } + if ($curtime-$mtime < 1800) { $numusers++; } } closedir(LONIDS); }