--- loncom/lond 2000/12/05 19:14:59 1.26 +++ loncom/lond 2004/03/08 20:13:07 1.165.2.3 @@ -1,78 +1,553 @@ #!/usr/bin/perl # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) -# 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/26 Scott Harrison -# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer -# 12/05 Scott Harrison -# 12/05 Gerd Kortemeyer -# -# based on "Perl Cookbook" ISBN 1-56592-243-3 -# preforker - server who forks first -# runs as a daemon -# HUPs -# uses IDEA encryption +# +# $Id: lond,v 1.165.2.3 2004/03/08 20:13:07 albertel Exp $ +# +# Copyright Michigan State University Board of Trustees +# +# This file is part of the LearningOnline Network with CAPA (LON-CAPA). +# +# 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 +# (at your option) any later version. +# +# LON-CAPA is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# 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 +# +# /home/httpd/html/adm/gpl.txt +# + + +# http://www.lon-capa.org/ +# + +use strict; +use lib '/home/httpd/lib/perl/'; +use LONCAPA::Configuration; use IO::Socket; use IO::File; -use Apache::File; +#use Apache::File; use Symbol; use POSIX; use Crypt::IDEA; use LWP::UserAgent(); use GDBM_File; use Authen::Krb4; +use Authen::Krb5; +use lib '/home/httpd/lib/perl/'; +use localauth; +use File::Copy; + +my $DEBUG = 0; # Non zero to enable debug log entries. + +my $status=''; +my $lastlog=''; + +my $VERSION='$Revision: 1.165.2.3 $'; #' stupid emacs +my $remoteVERSION; +my $currenthostid; +my $currentdomainid; + +my $client; +my $clientip; +my $clientname; + +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 +# -# grabs exception and records it to log before exiting -sub catchexception { - my ($signal)=@_; - $SIG{'QUIT'}='DEFAULT'; - $SIG{__DIE__}='DEFAULT'; - &logthis("CRITICAL: " - ."ABNORMAL EXIT. Child $$ for server $wasserver died through " - ."$signal with this parameter->[$@]"); - if ($client) { print $client "error: $@\n"; } - die($@); +my $ConnectionType; + +my %hostid; +my %hostdom; +my %hostip; + +my %managers; # Ip -> manager names + +my %perlvar; # Will have the apache conf defined perl vars. + +# +# The array below are password error strings." +# +my $lastpwderror = 13; # Largest error number from lcpasswd. +my @passwderrors = ("ok", + "lcpasswd must be run as user 'www'", + "lcpasswd got incorrect number of arguments", + "lcpasswd did not get the right nubmer of input text lines", + "lcpasswd too many simultaneous pwd changes in progress", + "lcpasswd User does not exist.", + "lcpasswd Incorrect current passwd", + "lcpasswd Unable to su to root.", + "lcpasswd Cannot set new passwd.", + "lcpasswd Username has invalid characters", + "lcpasswd Invalid characters in password", + "11", "12", + "lcpasswd Password mismatch"); + + +# The array below are lcuseradd error strings.: + +my $lastadderror = 13; +my @adderrors = ("ok", + "User ID mismatch, lcuseradd must run as user www", + "lcuseradd Incorrect number of command line parameters must be 3", + "lcuseradd Incorrect number of stdinput lines, must be 3", + "lcuseradd Too many other simultaneous pwd changes in progress", + "lcuseradd User does not exist", + "lcuseradd Unable to make www member of users's group", + "lcuseradd Unable to su to root", + "lcuseradd Unable to set password", + "lcuseradd Usrname has invalid characters", + "lcuseradd Password has an invalid character", + "lcuseradd User already exists", + "lcuseradd Could not add user.", + "lcuseradd Password mismatch"); + + +# +# GetCertificate: Given a transaction that requires a certificate, +# this function will extract the certificate from the transaction +# request. Note that at this point, the only concept of a certificate +# is the hostname to which we are connected. +# +# Parameter: +# request - The request sent by our client (this parameterization may +# need to change when we really use a certificate granting +# authority. +# +sub GetCertificate { + my $request = shift; + + return $clientip; } -# grabs exception and records it to log before exiting -# NOTE: we must NOT use the regular (non-overrided) die function in -# the code because a handler CANNOT be attached to it -# (despite what some of the documentation says about SIG{__DIE__}. +# +# 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")); +} + + +# +# 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 (!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); + open(MGRPIPE, "/usr/bin/host $dnsname |") || die "Can't make host pipeline"; + my $dnsinfo = ; + chomp $dnsinfo; + close MGRPIPE; + my($jname, $jhas, $jaddress, $hostip) = split(/ /, $dnsinfo); + $managers{$hostip} = $cluname; + } else { + $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 +# just the connecting loncapa client name. This is checked +# against a valid client list in the configuration. +# +# +sub ValidManager { + my $certificate = shift; -sub catchdie { - my ($message)=@_; + return isManager; +} +# +# CopyFile: Called as part of the process of installing a +# new configuration file. This function copies an existing +# file to a backup file. +# Parameters: +# oldfile - Name of the file to backup. +# newfile - Name of the backup file. +# Return: +# 0 - Failure (errno has failure reason). +# 1 - Success. +# +sub CopyFile { + my $oldfile = shift; + my $newfile = shift; + + # The file must exist: + + if(-e $oldfile) { + + # Read the old file. + + my $oldfh = IO::File->new("< $oldfile"); + if(!$oldfh) { + return 0; + } + my @contents = <$oldfh>; # Suck in the entire file. + + # write the backup file: + + my $newfh = IO::File->new("> $newfile"); + if(!(defined $newfh)){ + return 0; + } + my $lines = scalar @contents; + for (my $i =0; $i < $lines; $i++) { + print $newfh ($contents[$i]); + } + + $oldfh->close; + $newfh->close; + + chmod(0660, $newfile); + + return 1; + + } else { + return 0; + } +} +# +# 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) { + open(PIPE, " /usr/bin/host $name |") || die "Cant' make host pipeline"; + my $hostinfo = ; + close PIPE; + + my ($hostname, $has, $address, $ipnew) = split(/ /,$hostinfo); + &logthis(''. + "hostname = $hostname me = $me, name = $name actual ip = $ipnew "); + + if ($hostname eq $name) { # Lookup succeeded.. + &logthis(' look up ok '); + $ip = $ipnew; + } else { + &logthis(' Lookup failed: ' + .$hostname." ne $name "); + } + # 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 +# - The .tmp file is then mv'd to +# This lugubrious procedure is done to ensure that we are never without +# a valid, even if dated, version of the file regardless of who crashes +# and when the crash occurs. +# +# Parameters: +# Name of the file +# File Contents. +# Return: +# nonzero - success. +# 0 - failure and $! has an errno. +# +sub InstallFile { + my $Filename = shift; + my $Contents = shift; + 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 + + chmod(0660, $TempFile); + + # Now we can move install the file in position. + + move($TempFile, $Filename); + + return 1; +} + +# +# PushFile: Called to do an administrative push of a file. +# - Ensure the file being pushed is one we support. +# - Backup the old file to +# - Separate the contents of the new file out from the +# rest of the request. +# - Write the new file. +# Parameter: +# Request - The entire user request. This consists of a : separated +# string pushfile:tablename:contents. +# NOTE: The contents may have :'s in it as well making things a bit +# more interesting... but not much. +# Returns: +# String to send to client ("ok" or "refused" if bad file). +# +sub PushFile { + my $request = shift; + my ($command, $filename, $contents) = split(":", $request, 3); + + # At this point in time, pushes for only the following tables are + # supported: + # hosts.tab ($filename eq host). + # domain.tab ($filename eq domain). + # Construct the destination filename or reject the request. + # + # lonManage is supposed to ensure this, however this session could be + # 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 { + return "refused"; + } + # + # >copy< the old table to the backup table + # don't rename in case system crashes/reboots etc. in the time + # window between a rename and write. + # + my $backupfile = $tablefile; + $backupfile =~ s/\.tab$/.old/; + if(!CopyFile($tablefile, $backupfile)) { + &logthis(' CopyFile from '.$tablefile." to ".$backupfile." failed "); + return "error:$!"; + } + &logthis(' Pushfile: backed up ' + .$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." $! "); + return "error:$!"; + } + else { + &logthis(' Installed new '.$tablefile + .""); + + } + + + # Indicate success: + + return "ok"; + +} + +# +# Called to re-init either lonc or lond. +# +# Parameters: +# request - The full request by the client. This is of the form +# reinit: +# where is allowed to be either of +# lonc or lond +# +# Returns: +# The string to be sent back to the client either: +# ok - Everything worked just fine. +# error:why - There was a failure and why describes the reason. +# +# +sub ReinitProcess { + my $request = shift; + + + # separate the request (reinit) from the process identifier and + # validate it producing the name of the .pid file for the process. + # + # + my ($junk, $process) = split(":", $request); + my $processpidfile = $perlvar{'lonDaemons'}.'/logs/'; + if($process eq 'lonc') { + $processpidfile = $processpidfile."lonc.pid"; + if (!open(PIDFILE, "< $processpidfile")) { + return "error:Open failed for $processpidfile"; + } + my $loncpid = ; + close(PIDFILE); + logthis(' Reinitializing lonc pid='.$loncpid + .""); + kill("USR2", $loncpid); + } elsif ($process eq 'lond') { + logthis(' Reinitializing self (lond) '); + &UpdateHosts; # Lond is us!! + } else { + &logthis('"); + return "error:Invalid process identifier $process"; + } + return 'ok'; +} + +# +# Convert an error return code from lcpasswd to a string value. +# +sub lcpasswdstrerror { + my $ErrorCode = shift; + if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { + return "lcpasswd Unrecognized error return value ".$ErrorCode; + } else { + return $passwderrors[$ErrorCode]; + } +} + +# +# Convert an error return code from lcuseradd to a string value: +# +sub lcuseraddstrerror { + my $ErrorCode = shift; + if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) { + return "lcuseradd - Unrecognized error code: ".$ErrorCode; + } else { + return $adderrors[$ErrorCode]; + } +} + +# grabs exception and records it to log before exiting +sub catchexception { + my ($error)=@_; $SIG{'QUIT'}='DEFAULT'; $SIG{__DIE__}='DEFAULT'; + &status("Catching exception"); &logthis("CRITICAL: " - ."ABNORMAL EXIT. Child $$ for server $wasserver died through " - ."\_\_DIE\_\_ with this parameter->[$message]"); - if ($client) { print $client "error: $message\n"; } - die($message); + ."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(); + die($error); } +sub timeout { + &status("Handling Timeout"); + &logthis("CRITICAL: TIME OUT ".$$.""); + &catchexception('Timeout'); +} # -------------------------------- Set signal handlers to record abnormal exits $SIG{'QUIT'}=\&catchexception; $SIG{__DIE__}=\&catchexception; -# ------------------------------------ Read httpd access.conf and get variables - -open (CONFIG,"/etc/httpd/conf/access.conf") - || catchdie "Can't read access.conf"; - -while ($configline=) { - if ($configline =~ /PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } +# ---------------------------------- Read loncapa_apache.conf and loncapa.conf +&status("Read loncapa.conf and loncapa_apache.conf"); +my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); +%perlvar=%{$perlvarref}; +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.' |\ + mailto $emailto -s '$subj' > /dev/null"); + exit 1; } -close(CONFIG); # --------------------------------------------- Check if other instance running @@ -82,24 +557,12 @@ if (-e $pidfile) { my $lfh=IO::File->new("$pidfile"); my $pide=<$lfh>; chomp($pide); - if (kill 0 => $pide) { catchdie "already running"; } + if (kill 0 => $pide) { die "already running"; } } -$PREFORK=4; # number of children to maintain, at least four spare - # ------------------------------------------------------------- Read hosts file -open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") - || catchdie "Can't read host file"; -while ($configline=) { - my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); - chomp($ip); - $hostid{$ip}=$id; - if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } - $PREFORK++; -} -close(CONFIG); # establish SERVER socket, bind and listen. $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'}, @@ -107,43 +570,187 @@ $server = IO::Socket::INET->new(LocalPor Proto => 'tcp', Reuse => 1, Listen => 10 ) - or catchdie "making socket: $@\n"; + or die "making socket: $@\n"; # --------------------------------------------------------- Do global variables # global variables -$MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should - # process -%children = (); # keys are current child process IDs -$children = 0; # current number of children +my %children = (); # keys are current child process IDs sub REAPER { # takes care of dead children $SIG{CHLD} = \&REAPER; - my $pid = wait; - $children --; - &logthis("Child $pid died"); - delete $children{$pid}; + &status("Handling child death"); + my $pid; + do { + $pid = waitpid(-1,&WNOHANG()); + if (defined($children{$pid})) { + &logthis("Child $pid died"); + delete($children{$pid}); + } else { + &logthis("Unknown Child $pid died"); + } + } while ( $pid > 0 ); + foreach my $child (keys(%children)) { + $pid = waitpid($child,&WNOHANG()); + if ($pid > 0) { + &logthis("Child $child - $pid looks like we missed it's death"); + delete($children{$pid}); + } + } + &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; - close($server); # free up socket + &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 } +# +# Kill off hashes that describe the host table prior to re-reading it. +# Hashes affected are: +# %hostid, %hostdom %hostip +# +sub KillHostHashes { + foreach my $key (keys %hostid) { + delete $hostid{$key}; + } + foreach my $key (keys %hostdom) { + delete $hostdom{$key}; + } + foreach my $key (keys %hostip) { + delete $hostip{$key}; + } +} +# +# Read in the host table from file and distribute it into the various hashes: +# +# - %hostid - Indexed by IP, the loncapa hostname. +# - %hostdom - Indexed by loncapa hostname, the domain. +# - %hostip - Indexed by hostid, the Ip address of the host. +sub ReadHostTable { + + open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; + + while (my $configline=) { + if (!($configline =~ /^\s*\#/)) { + my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); + chomp($ip); $ip=~s/\D+$//; + $hostid{$ip}=$id; + $hostdom{$id}=$domain; + $hostip{$id}=$ip; + if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } + } + } + close(CONFIG); +} +# +# Reload the Apache daemon's state. +# This is done by invoking /home/httpd/perl/apachereload +# a setuid perl script that can be root for us to do this job. +# +sub ReloadApache { + my $execdir = $perlvar{'lonDaemons'}; + my $script = $execdir."/apachereload"; + system($script); +} + +# +# Called in response to a USR2 signal. +# - Reread hosts.tab +# - All children connected to hosts that were removed from hosts.tab +# are killed via SIGINT +# - All children connected to previously existing hosts are sent SIGUSR1 +# - Our internal hosts hash is updated to reflect the new contents of +# hosts.tab causing connections from hosts added to hosts.tab to +# 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 + # on. These need to be matched against records in the hosts.tab + # Any ip's no longer in the table get killed off they correspond to + # either dropped or changed hosts. Note that the re-read of the table + # will take care of new and changed hosts as connections come into being. + + + KillHostHashes; + ReadHostTable; + + foreach my $child (keys %children) { + my $childip = $children{$child}; + if(!$hostid{$childip}) { + logthis(' UpdateHosts killing child ' + ." $child for ip $childip "); + kill('INT', $child); + } else { + logthis(' keeping child for ip ' + ." $childip (pid=$child) "); + } + } + ReloadApache; + &status("Finished reloading hosts.tab"); +} + + +sub checkchildren { + &status("Checking on the children (sending signals)"); + &initnewstatus(); + &logstatus(); + &logthis('Going to check on the children'); + my $docdir=$perlvar{'lonDocRoot'}; + foreach (sort keys %children) { + sleep 1; + unless (kill 'USR1' => $_) { + &logthis ('Child '.$_.' is dead'); + &logstatus($$.' is dead'); + } + } + 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); + } + } + } + $SIG{ALRM} = 'DEFAULT'; + $SIG{__DIE__} = \&catchexception; + &status("Finished checking children"); +} + # --------------------------------------------------------------------- Logging sub logthis { @@ -152,9 +759,76 @@ sub logthis { my $fh=IO::File->new(">>$execdir/logs/lond.log"); my $now=time; my $local=localtime($now); + $lastlog=$local.': '.$message; print $fh "$local ($$): $message\n"; } +# ------------------------- Conditional log if $DEBUG true. +sub Debug { + my $message = shift; + if($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. +# +sub Reply { + my $fd = shift; + my $reply = shift; + my $request = shift; + + print $fd $reply; + Debug("Request was $request Reply was $reply"); + +} +# ------------------------------------------------------------------ Log status + +sub logstatus { + &status("Doing logging"); + my $docdir=$perlvar{'lonDocRoot'}; + { + my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); + print $fh $$."\t".$clientname."\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(); + } + &status("Finished logging"); +} + +sub initnewstatus { + my $docdir=$perlvar{'lonDocRoot'}; + my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); + my $now=time; + my $local=localtime($now); + print $fh "LOND status $local - parent $$\n\n"; + opendir(DIR,"$docdir/lon-status/londchld"); + while (my $filename=readdir(DIR)) { + unlink("$docdir/lon-status/londchld/$filename"); + } + closedir(DIR); +} + +# -------------------------------------------------------------- Status setting + +sub status { + my $what=shift; + my $now=time; + my $local=localtime($now); + $status=$local.': '.$what; + $0='lond: '.$what.' '.$local; +} # -------------------------------------------------------- Escape Special Chars @@ -184,13 +858,6 @@ sub reconlonc { if (kill 0 => $loncpid) { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; - sleep 1; - if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, give it another try"); - sleep 5; - if (-e "$peerfile") { return; } - &logthis( - "WARNING: $peerfile still not there, giving up"); } else { &logthis( "CRITICAL: " @@ -220,11 +887,12 @@ sub subreply { sub reply { my ($cmd,$server)=@_; my $answer; - if ($server ne $perlvar{'lonHostID'}) { + 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); @@ -288,766 +956,2309 @@ sub ishome { # ======================================================= Continue main program # ---------------------------------------------------- Fork once and dissociate -$fpid=fork; +my $fpid=fork; exit if $fpid; -catchdie "Couldn't fork: $!" unless defined ($fpid); +die "Couldn't fork: $!" unless defined ($fpid); -POSIX::setsid() or catchdie "Can't start new session: $!"; +POSIX::setsid() or die "Can't start new session: $!"; # ------------------------------------------------------- Write our PID on disk -$execdir=$perlvar{'lonDaemons'}; +my $execdir=$perlvar{'lonDaemons'}; open (PIDSAVE,">$execdir/logs/lond.pid"); print PIDSAVE "$$\n"; close(PIDSAVE); &logthis("CRITICAL: ---------- Starting ----------"); +&status('Starting'); + -# ------------------------------------------------------- Now we are on our own - -# Fork off our children. -for (1 .. $PREFORK) { - make_new_child(); -} # ----------------------------------------------------- Install signal handlers + $SIG{CHLD} = \&REAPER; $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; $SIG{HUP} = \&HUPSMAN; +$SIG{USR1} = \&checkchildren; +$SIG{USR2} = \&UpdateHosts; + +# Read the host hashes: + +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. -# And maintain the population. while (1) { - sleep; # wait for a signal (i.e., child's death) - for ($i = $children; $i < $PREFORK; $i++) { - make_new_child(); # top up the child pool - } + &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; - &logthis("Attempting to start child"); + + $client = shift; + &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 catchdie "Can't block SIGINT for fork: $!\n"; - - catchdie "fork: $!" unless defined ($pid = fork); + or die "Can't block SIGINT for fork: $!\n"; + + die "fork: $!" unless defined ($pid = fork); + + $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of + # connection liveness. + + # + # Figure out who we're talking to so we can record the peer in + # the pid hash. + # + my $caller = getpeername($client); + my ($port,$iaddr)=unpack_sockaddr_in($caller); + $clientip=inet_ntoa($iaddr); if ($pid) { # Parent records the child's birth and returns. sigprocmask(SIG_UNBLOCK, $sigset) - or catchdie "Can't unblock SIGINT for fork: $!\n"; - $children{$pid} = 1; - $children++; + or die "Can't unblock SIGINT for fork: $!\n"; + $children{$pid} = $clientip; + &status('Started child '.$pid); return; } else { # Child can *not* return from this subroutine. $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before - + $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns + #don't get intercepted + $SIG{USR1}= \&logstatus; + $SIG{ALRM}= \&timeout; + $lastlog='Forked '; + $status='Forked'; + # unblock signals sigprocmask(SIG_UNBLOCK, $sigset) - or catchdie "Can't unblock SIGINT for fork: $!\n"; + or die "Can't unblock SIGINT for fork: $!\n"; - $tmpsnum=0; - - # handle connections until we've reached $MAX_CLIENTS_PER_CHILD - for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { - $client = $server->accept() or last; + my $tmpsnum=0; +#---------------------------------------------------- kerberos 5 initialization + &Authen::Krb5::init_context(); + &Authen::Krb5::init_ets(); + &status('Accepted connection'); # ============================================================================= # do something with the connection # ----------------------------------------------------------------------------- - # see if we know client and check for spoof IP by challenge - my $caller=getpeername($client); - my ($port,$iaddr)=unpack_sockaddr_in($caller); - my $clientip=inet_ntoa($iaddr); - my $clientrec=($hostid{$clientip} ne undef); - &logthis( -"INFO: Connect from $clientip ($hostid{$clientip})"); - my $clientok; - if ($clientrec) { - my $remotereq=<$client>; - $remotereq=~s/\W//g; - if ($remotereq eq 'init') { - my $challenge="$$".time; - print $client "$challenge\n"; - $remotereq=<$client>; - $remotereq=~s/\W//g; - if ($challenge eq $remotereq) { - $clientok=1; - print $client "ok\n"; - } else { - &logthis( - "WARNING: $clientip did not reply challenge"); - print $client "bye\n"; - } - } else { - &logthis( - "WARNING: " - ."$clientip failed to initialize: >$remotereq< "); - print $client "bye\n"; - } + # see if we know client and check for spoof IP by challenge + + 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"); - print $client "bye\n"; - } - 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 - &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); - &logthis( - "Established connection: $hostid{$clientip}"); + + 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"); + } + &logthis("Established connection: $clientname"); + &status('Will listen to '.$clientname); # ------------------------------------------------------------ Process requests - while (my $userinput=<$client>) { + while (my $userinput=<$client>) { chomp($userinput); + Debug("Request = $userinput\n"); + &status('Processing '.$clientname.': '.$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; - } + 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 "$perlvar{'lonHostID'}\n"; + if ($userinput =~ /^ping/) { # client only + if(isClient) { + print $client "$currenthostid\n"; + } else { + Reply($client, "refused\n", $userinput); + } # ------------------------------------------------------------------------ pong - } elsif ($userinput =~ /^pong/) { - $reply=reply("ping",$hostid{$clientip}); - print $client "$perlvar{'lonHostID'}:$reply\n"; + }elsif ($userinput =~ /^pong/) { # client only + if(isClient) { + my $reply=&reply("ping",$clientname); + print $client "$currenthostid:$reply\n"; + } else { + Reply($client, "refused\n", $userinput); + } # ------------------------------------------------------------------------ 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=$perlvar{'lonHostID'}.$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"; + } elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs + 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; + 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"; + } elsif ($userinput =~ /^load/) { # client only + if (isClient) { + 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"; + } else { + Reply($client, "refused\n", $userinput); + + } +# -------------------------------------------------------------------- userload + } elsif ($userinput =~ /^userload/) { # client only + if(isClient) { + my $userloadpercent=&userload(); + print $client "$userloadpercent\n"; + } else { + Reply($client, "refused\n", $userinput); + + } +# +# Transactions requiring encryption: +# +# ----------------------------------------------------------------- currentauth + } elsif ($userinput =~ /^currentauth/) { + if (($wasenc==1) && isClient) { # Encoded & client only. + 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 { + Reply($client, "refused\n", $userinput); + + } +#--------------------------------------------------------------------- pushfile + } elsif($userinput =~ /^pushfile/) { # encoded & manager. + if(($wasenc == 1) && isManager) { + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + my $reply = PushFile($userinput); + print $client "$reply\n"; + } else { + print $client "refused\n"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +#--------------------------------------------------------------------- reinit + } elsif($userinput =~ /^reinit/) { # Encoded and manager + if (($wasenc == 1) && isManager) { + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + chomp($userinput); + my $reply = ReinitProcess($userinput); + print $client "$reply\n"; + } else { + print $client "refused\n"; + } + } else { + Reply($client, "refused\n", $userinput); + + + } # ------------------------------------------------------------------------ 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') { - $pwdcorrect= - (crypt($upass,$contentpwd) eq $contentpwd); - } elsif ($howpwd eq 'unix') { - $contentpwd=(getpwnam($uname))[1]; - $pwdcorrect= - (crypt($upass,$contentpwd) eq $contentpwd); - } elsif ($howpwd eq 'krb4') { - $pwdcorrect=( - Authen::Krb4::get_pw_in_tkt($uname,"", - $contentpwd,'krbtgt',$contentpwd,1, - $upass) == 0); - } - if ($pwdcorrect) { - print $client "authorized\n"; - } else { - print $client "non_authorized\n"; - } - } else { - print $client "unknown_user\n"; - } - } else { - print $client "refused\n"; - } + } elsif ($userinput =~ /^auth/) { # Encoded and client only. + if (($wasenc==1) && isClient) { + 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 { + Reply($client, "refused\n", $userinput); + + } # ---------------------------------------------------------------------- passwd - } elsif ($userinput =~ /^passwd/) { - if ($wasenc==1) { - my - ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); - chomp($npass); - 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') { - if (crypt($upass,$contentpwd) eq $contentpwd) { - my $salt=time; - $salt=substr($salt,6,2); - my $ncpass=crypt($npass,$salt); - { my $pf = IO::File->new(">$passfilename"); - print $pf "internal:$ncpass\n";; } - print $client "ok\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"; - } + } elsif ($userinput =~ /^passwd/) { # encoded and client + if (($wasenc==1) && isClient) { + 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 { + Reply($client, "refused\n", $userinput); + + } +# -------------------------------------------------------------------- makeuser + } elsif ($userinput =~ /^makeuser/) { # encoded and client. + &Debug("Make user received"); + my $oldumask=umask(0077); + if (($wasenc==1) && isClient) { + 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"; + } + } + } + unless ($fperror) { + my $result=&make_passwd_file($uname, $umode,$npass, + $passfilename); + print $client $result; + } else { + print $client "$fperror\n"; + } + } + } else { + Reply($client, "refused\n", $userinput); + + } + umask($oldumask); +# -------------------------------------------------------------- changeuserauth + } elsif ($userinput =~ /^changeuserauth/) { # encoded & client + &Debug("Changing authorization"); + if (($wasenc==1) && isClient) { + 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 { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------------ 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"; - } + } elsif ($userinput =~ /^home/) { # client clear or encoded + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ---------------------------------------------------------------------- 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); - $now=time; - $since=$now-$atime; - if ($since>$perlvar{'lonExpire'}) { - $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 $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"; - } + } elsif ($userinput =~ /^update/) { # client clear or encoded. + if(isClient) { + 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","$clientname"); + unlink("$fname"); + } else { + my $transname="$fname.in.transfer"; + my $remoteurl= + &reply("sub:$fname","$clientname"); + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# -------------------------------------- fetch a user file from a remote server + } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc. + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# ------------------------------------------ authenticate access to a user file + } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ----------------------------------------------------------------- unsubscribe - } elsif ($userinput =~ /^unsub/) { - my ($cmd,$fname)=split(/:/,$userinput); - if (-e $fname) { - if (unlink("$fname.$hostid{$clientip}")) { - print $client "ok\n"; - } else { - print $client "not_subscribed\n"; - } - } else { - print $client "not_found\n"; - } + } elsif ($userinput =~ /^unsub/) { + if(isClient) { + my ($cmd,$fname)=split(/:/,$userinput); + if (-e $fname) { + print $client &unsub($client,$fname,$clientip); + } else { + print $client "not_found\n"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------- subscribe - } elsif ($userinput =~ /^sub/) { - my ($cmd,$fname)=split(/:/,$userinput); - my $ownership=ishome($fname); - if ($ownership eq 'owner') { - if (-e $fname) { - if (-d $fname) { - print $client "directory\n"; - } else { - $now=time; - { - my $sh; - if ($sh= - IO::File->new(">$fname.$hostid{$clientip}")) { - print $sh "$clientip:$now\n"; - } - } - $fname=~s/\/home\/httpd\/html\/res/raw/; - $fname="http://$thisserver/".$fname; - print $client "$fname\n"; - } - } else { - print $client "not_found\n"; - } - } else { - print $client "rejected\n"; - } + } elsif ($userinput =~ /^sub/) { + if(isClient) { + print $client &subscribe($userinput,$clientip); + } else { + Reply($client, "refused\n", $userinput); + + } +# ------------------------------------------------------------- current version + } elsif ($userinput =~ /^currentversion/) { + if(isClient) { + my ($cmd,$fname)=split(/:/,$userinput); + print $client ¤tversion($fname)."\n"; + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------------- 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:$!\n"; - } - } + } elsif ($userinput =~ /^log/) { + if(isClient) { + 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:$clientname:$what\n"; + print $client "ok\n"; + } else { + print $client "error: ".($!+0) + ." IO::File->new Failed " + ."while attempting log\n"; + } + } + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------------- 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; - { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname/$namespace.hist") - ) { print $hfh "P:$now:$what\n"; } - } - my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); - $hash{$key}=$value; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } - } else { - print $client "refused\n"; - } + } elsif ($userinput =~ /^put/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# ------------------------------------------------------------------- inc + } elsif ($userinput =~ /^inc:/) { + if(isClient) { + 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); + # We could check that we have a number... + if (! defined($value) || $value eq '') { + $value = 1; + } + $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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # -------------------------------------------------------------------- rolesput - } elsif ($userinput =~ /^rolesput/) { - if ($wasenc==1) { - my ($cmd,$exedom,$exeuser,$udom,$uname,$what) - =split(/:/,$userinput); - 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); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); - $hash{$key}=$value; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } - } else { - print $client "refused\n"; - } + } elsif ($userinput =~ /^rolesput/) { + if(isClient) { + &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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# -------------------------------------------------------------------- rolesdel + } elsif ($userinput =~ /^rolesdel/) { + if(isClient) { + &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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------------- 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=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { - for ($i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^get/) { + if(isClient) { + 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"; + } + } + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------------ 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=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { - for ($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:$!\n"; - } - } else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^eget/) { + if (isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------------- 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; - { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname/$namespace.hist") - ) { print $hfh "D:$now:$what\n"; } - } - my @keys=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { - foreach $key (@keys) { - delete($hash{$key}); - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^del/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------------ 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=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { - foreach $key (keys %hash) { - $qresult.="$key&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^keys/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# ----------------------------------------------------------------- dumpcurrent + } elsif ($userinput =~ /^currentdump/) { + if (isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + } # ------------------------------------------------------------------------ dump - } elsif ($userinput =~ /^dump/) { - my ($cmd,$udom,$uname,$namespace) - =split(/:/,$userinput); - $namespace=~s/\//\_/g; - $namespace=~s/\W//g; - my $proname=propath($udom,$uname); - my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { - foreach $key (keys %hash) { - $qresult.="$key=$hash{$key}&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^dump/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ----------------------------------------------------------------------- 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; - { - my $hfh; - if ( - $hfh=IO::File->new(">>$proname/$namespace.hist") - ) { print $hfh "P:$now:$rid:$what\n"; } - } - my @pairs=split(/\&/,$what); - - 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 $pair (@pairs) { - ($key,$value)=split(/=/,$pair); - $allkeys.=$key.':'; - $hash{"$version:$rid:$key"}=$value; - } - $allkeys=~s/:$//; - $hash{"$version:keys:$rid"}=$allkeys; - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } - } else { - print $client "refused\n"; - } + } elsif ($userinput =~ /^store/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # --------------------------------------------------------------------- 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=''; - 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:$!\n"; - } - } else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^restore/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# -------------------------------------------------------------------- chatsend + } elsif ($userinput =~ /^chatsend/) { + if(isClient) { + my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); + &chatadd($cdom,$cnum,$newpost); + print $client "ok\n"; + } else { + Reply($client, "refused\n", $userinput); + + } +# -------------------------------------------------------------------- chatretr + } elsif ($userinput =~ /^chatretr/) { + if(isClient) { + my + ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); + my $reply=''; + foreach (&getchat($cdom,$cnum,$udom,$uname)) { + $reply.=&escape($_).':'; + } + $reply=~s/\:$//; + print $client $reply."\n"; + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------- querysend - } elsif ($userinput =~ /^querysend/) { - my ($cmd,$query)=split(/:/,$userinput); - $query=~s/\n*$//g; - print $client sqlreply("$hostid{$clientip}\&$query")."\n"; + } elsif ($userinput =~ /^querysend/) { + if(isClient) { + my ($cmd,$query, + $arg1,$arg2,$arg3)=split(/\:/,$userinput); + $query=~s/\n*$//g; + print $client "". + sqlreply("$clientname\&$query". + "\&$arg1"."\&$arg2"."\&$arg3")."\n"; + } else { + Reply($client, "refused\n", $userinput); + + } # ------------------------------------------------------------------ queryreply - } elsif ($userinput =~ /^queryreply/) { - my ($cmd,$id,$reply)=split(/:/,$userinput); - my $store; - my $execdir=$perlvar{'lonDaemons'}; - if ($store=IO::File->new(">$execdir/tmp/$id")) { - print $store $reply; - close $store; - print $client "ok\n"; - } - else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^queryreply/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# ----------------------------------------------------------------- courseidput + } elsif ($userinput =~ /^courseidput/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# ---------------------------------------------------------------- courseiddump + } elsif ($userinput =~ /^courseiddump/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ----------------------------------------------------------------------- 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); - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); - $hash{$key}=$value; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^idput/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ----------------------------------------------------------------------- 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=''; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { - for ($i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error:$!\n"; - } - } else { - print $client "error:$!\n"; - } + } elsif ($userinput =~ /^idget/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # ---------------------------------------------------------------------- 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:$!\n"; - } - + } elsif ($userinput =~ /^tmpput/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } + # ---------------------------------------------------------------------- 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:$!\n"; - } - + } elsif ($userinput =~ /^tmpget/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# ---------------------------------------------------------------------- tmpdel + } elsif ($userinput =~ /^tmpdel/) { + if(isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } # -------------------------------------------------------------------------- ls - } elsif ($userinput =~ /^ls/) { - my ($cmd,$ulsdir)=split(/:/,$userinput); - my $ulsout=''; - my $ulsfn; - if (-e $ulsdir) { - while ($ulsfn=<$ulsdir/*>) { - my @ulsstats=stat($ulsfn); - $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; - } - } else { - $ulsout='no_such_dir'; - } - if ($ulsout eq '') { $ulsout='empty'; } - print $client "$ulsout\n"; + } elsif ($userinput =~ /^ls/) { + if(isClient) { + 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"; + } else { + Reply($client, "refused\n", $userinput); + + } +# ----------------------------------------------------------------- setannounce + } elsif ($userinput =~ /^setannounce/) { + if (isClient) { + 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"; + } + } else { + Reply($client, "refused\n", $userinput); + + } +# ------------------------------------------------------------------ Hanging up + } elsif (($userinput =~ /^exit/) || + ($userinput =~ /^init/)) { # no restrictions. + &logthis( + "Client $clientip ($clientname) hanging up: $userinput"); + print $client "bye\n"; + $client->shutdown(2); # shutdown the socket forcibly. + $client->close(); + last; + +# ---------------------------------- set current host/domain + } elsif ($userinput =~ /^sethost:/) { + if (isClient) { + print $client &sethost($userinput)."\n"; + } else { + print $client "refused\n"; + } +#---------------------------------- request file (?) version. + } elsif ($userinput =~/^version:/) { + if (isClient) { + print $client &version($userinput)."\n"; + } else { + print $client "refused\n"; + } # ------------------------------------------------------------- unknown command - } else { - # unknown command - print $client "unknown_cmd\n"; - } -# ------------------------------------------------------ client unknown, refuse - } - } else { - print $client "refused\n"; - &logthis("WARNING: " - ."Rejected client $clientip, closing connection"); - } - &logthis("CRITICAL: " - ."Disconnect from $clientip ($hostid{$clientip})"); + + } else { + # unknown command + print $client "unknown_cmd\n"; + } +# -------------------------------------------------------------------- complete + alarm(0); + &status('Listening to '.$clientname); + } +# --------------------------------------------- client unknown or fishy, refuse + } else { + print $client "refused\n"; + $client->close(); + &logthis("WARNING: " + ."Rejected client $clientip, closing connection"); + } + } + # ============================================================================= - } - # tidy up gracefully and finish + &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; - # this exit is VERY important, otherwise the child will become - # a producer of more and more children, forking yourself into - # process death. - exit; +} + + +# +# Checks to see if the input roleput request was to set +# an author role. If so, invokes the lchtmldir script to set +# up a correct public_html +# Parameters: +# request - The request sent to the rolesput subchunk. +# We're looking for /domain/_au +# domain - The domain in which the user is having roles doctored. +# user - Name of the user for which the role is being put. +# authtype - The authentication type associated with the user. +# +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"); + if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... + my $execdir = $perlvar{'lonDaemons'}; + my $userhome= "/home/$user" ; + &logthis("system $execdir/lchtmldir $userhome $user $authtype"); + system("$execdir/lchtmldir $userhome $user $authtype"); + } +} +# +# 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 +{ + my $domain = shift; + my $user = shift; + + Debug("GetAuthType( $domain, $user ) \n"); + my $proname = &propath($domain, $user); + my $passwdfile = "$proname/passwd"; + if( -e $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 { + Debug("Returning nouser"); + return "nouser"; + } +} + +sub addline { + my ($fname,$hostid,$ip,$newline)=@_; + my $contents; + my $found=0; + my $expr='^'.$hostid.':'.$ip.':'; + $expr =~ s/\./\\\./g; + my $sh; + if ($sh=IO::File->new("$fname.subscription")) { + while (my $subline=<$sh>) { + if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} + } + $sh->close(); + } + $sh=IO::File->new(">$fname.subscription"); + if ($contents) { print $sh $contents; } + if ($newline) { print $sh $newline; } + $sh->close(); + return $found; +} + +sub getchat { + my ($cdom,$cname,$udom,$uname)=@_; + my %hash; + my $proname=&propath($cdom,$cname); + my @entries=(); + if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", + &GDBM_READER(),0640)) { + @entries=map { $_.':'.$hash{$_} } sort keys %hash; + untie %hash; + } + my @participants=(); + my $cutoff=time-60; + if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", + &GDBM_WRCREAT(),0640)) { + $hash{$uname.':'.$udom}=time; + foreach (sort keys %hash) { + if ($hash{$_}>$cutoff) { + $participants[$#participants+1]='active_participant:'.$_; + } + } + untie %hash; + } + return (@participants,@entries); +} + +sub chatadd { + my ($cdom,$cname,$newchat)=@_; + my %hash; + my $proname=&propath($cdom,$cname); + my @entries=(); + my $time=time; + if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", + &GDBM_WRCREAT(),0640)) { + @entries=map { $_.':'.$hash{$_} } sort keys %hash; + my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); + my ($thentime,$idnum)=split(/\_/,$lastid); + my $newid=$time.'_000000'; + if ($thentime==$time) { + $idnum=~s/^0+//; + $idnum++; + $idnum=substr('000000'.$idnum,-6,6); + $newid=$time.'_'.$idnum; + } + $hash{$newid}=$newchat; + my $expired=$time-3600; + foreach (keys %hash) { + my ($thistime)=($_=~/(\d+)\_/); + if ($thistime<$expired) { + delete $hash{$_}; + } + } + untie %hash; + } + { + my $hfh; + if ($hfh=IO::File->new(">>$proname/chatroom.log")) { + print $hfh "$time:".&unescape($newchat)."\n"; + } + } +} + +sub unsub { + my ($fname,$clientip)=@_; + my $result; + if (unlink("$fname.$clientname")) { + $result="ok\n"; + } else { + $result="not_subscribed\n"; + } + if (-e "$fname.subscription") { + my $found=&addline($fname,$clientname,$clientip,''); + if ($found) { $result="ok\n"; } + } else { + if ($result != "ok\n") { $result="not_subscribed\n"; } + } + return $result; +} + +sub currentversion { + my $fname=shift; + my $version=-1; + my $ulsdir=''; + if ($fname=~/^(.+)\/[^\/]+$/) { + $ulsdir=$1; + } + my ($fnamere1,$fnamere2); + # remove version if already specified + $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; + # get the bits that go before and after the version number + if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { + $fnamere1=$1; + $fnamere2='.'.$2; + } + if (-e $fname) { $version=1; } + if (-e $ulsdir) { + if(-d $ulsdir) { + if (opendir(LSDIR,$ulsdir)) { + my $ulsfn; + while ($ulsfn=readdir(LSDIR)) { +# 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 ($1>$version) { $version=$1; } + } + } + } + closedir(LSDIR); + $version++; + } + } + } + return $version; +} + +sub thisversion { + my $fname=shift; + my $version=-1; + if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { + $version=$1; + } + return $version; +} + +sub subscribe { + my ($userinput,$clientip)=@_; + my $result; + my ($cmd,$fname)=split(/:/,$userinput); + my $ownership=&ishome($fname); + if ($ownership eq 'owner') { +# explitly asking for the current version? + unless (-e $fname) { + my $currentversion=¤tversion($fname); + if (&thisversion($fname)==$currentversion) { + if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { + my $root=$1; + my $extension=$2; + symlink($root.'.'.$extension, + $root.'.'.$currentversion.'.'.$extension); + unless ($extension=~/\.meta$/) { + symlink($root.'.'.$extension.'.meta', + $root.'.'.$currentversion.'.'.$extension.'.meta'); + } + } + } + } + if (-e $fname) { + if (-d $fname) { + $result="directory\n"; + } else { + if (-e "$fname.$clientname") {&unsub($fname,$clientip);} + my $now=time; + 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 + # the metadata + unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } + $fname=~s/\/home\/httpd\/html\/res/raw/; + $fname="http://$thisserver/".$fname; + $result="$fname\n"; + } + } else { + $result="not_found\n"; + } + } else { + $result="rejected\n"; + } + return $result; +} + +sub make_passwd_file { + my ($uname, $umode,$npass,$passfilename)=@_; + my $result="ok\n"; + if ($umode eq 'krb4' or $umode eq 'krb5') { + { + my $pf = IO::File->new(">$passfilename"); + print $pf "$umode:$npass\n"; + } + } elsif ($umode eq 'internal') { + my $salt=time; + $salt=substr($salt,6,2); + my $ncpass=crypt($npass,$salt); + { + &Debug("Creating internal auth"); + my $pf = IO::File->new(">$passfilename"); + print $pf "internal:$ncpass\n"; + } + } elsif ($umode eq 'localauth') { + { + my $pf = IO::File->new(">$passfilename"); + 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"; + } + } elsif ($umode eq 'none') { + { + my $pf = IO::File->new(">$passfilename"); + print $pf "none:\n"; + } + } else { + $result="auth_mode_error\n"; } + return $result; } +sub sethost { + my ($remotereq) = @_; + my (undef,$hostid)=split(/:/,$remotereq); + if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } + if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { + $currenthostid=$hostid; + $currentdomainid=$hostdom{$hostid}; + &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); + } else { + &logthis("Requested host id $hostid not an alias of ". + $perlvar{'lonHostID'}." refusing connection"); + return 'unable_to_set'; + } + return 'ok'; +} + +sub version { + my ($userinput)=@_; + $remoteVERSION=(split(/:/,$userinput))[1]; + return "version:$VERSION"; +} + +#There is a copy of this in lonnet.pm +sub userload { + my $numusers=0; + { + opendir(LONIDS,$perlvar{'lonIDsDir'}); + my $filename; + my $curtime=time; + while ($filename=readdir(LONIDS)) { + if ($filename eq '.' || $filename eq '..') {next;} + my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; + if ($curtime-$mtime < 1800) { $numusers++; } + } + closedir(LONIDS); + } + my $userloadpercent=0; + my $maxuserload=$perlvar{'lonUserLoadLim'}; + if ($maxuserload) { + $userloadpercent=100*$numusers/$maxuserload; + } + $userloadpercent=sprintf("%.2f",$userloadpercent); + return $userloadpercent; +} + +# ----------------------------------- POD (plain old documentation, CPAN style) + +=head1 NAME + +lond - "LON Daemon" Server (port "LOND" 5663) + +=head1 SYNOPSIS + +Usage: B + +Should only be run as user=www. This is a command-line script which +is invoked by B. There is no expectation that a typical user +will manually start B from the command-line. (In other words, +DO NOT START B YOURSELF.) + +=head1 DESCRIPTION + +There are two characteristics associated with the running of B, +PROCESS MANAGEMENT (starting, stopping, handling child processes) +and SERVER-SIDE ACTIVITIES (password authentication, user creation, +subscriptions, etc). These are described in two large +sections below. + +B + +Preforker - server who forks first. Runs as a daemon. HUPs. +Uses IDEA encryption + +B forks off children processes that correspond to the other servers +in the network. Management of these processes can be done at the +parent process level or the child process level. + +B is the location of log messages. + +The process management is now explained in terms of linux shell commands, +subroutines internal to this code, and signal assignments: + +=over 4 + +=item * + +PID is stored in B + +This is the process id number of the parent B process. + +=item * + +SIGTERM and SIGINT + +Parent signal assignment: + $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; + +Child signal assignment: + $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) +(The child dies and a SIGALRM is sent to parent, awaking parent from slumber + to restart a new child.) + +Command-line invocations: + B B<-s> SIGTERM I + B B<-s> SIGINT I + +Subroutine B: + This is only invoked for the B parent I. +This kills all the children, and then the parent. +The B file is cleared. + +=item * + +SIGHUP + +Current bug: + This signal can only be processed the first time +on the parent process. Subsequent SIGHUP signals +have no effect. + +Parent signal assignment: + $SIG{HUP} = \&HUPSMAN; + +Child signal assignment: + none (nothing happens) + +Command-line invocations: + B B<-s> SIGHUP I + +Subroutine B: + This is only invoked for the B parent I, +This kills all the children, and then the parent. +The B file is cleared. + +=item * + +SIGUSR1 + +Parent signal assignment: + $SIG{USR1} = \&USRMAN; + +Child signal assignment: + $SIG{USR1}= \&logstatus; + +Command-line invocations: + B B<-s> SIGUSR1 I + +Subroutine B: + When invoked for the B parent I, +SIGUSR1 is sent to all the children, and the status of +each connection is logged. + +=item * + +SIGUSR2 + +Parent Signal assignment: + $SIG{USR2} = \&UpdateHosts + +Child signal assignment: + NONE + + +=item * + +SIGCHLD + +Parent signal assignment: + $SIG{CHLD} = \&REAPER; + +Child signal assignment: + none + +Command-line invocations: + B B<-s> SIGCHLD I + +Subroutine B: + This is only invoked for the B parent I. +Information pertaining to the child is removed. +The socket port is cleaned up. + +=back + +B + +Server-side information can be accepted in an encrypted or non-encrypted +method. + +=over 4 + +=item ping + +Query a client in the hosts.tab table; "Are you there?" + +=item pong + +Respond to a ping query. + +=item ekey + +Read in encrypted key, make cipher. Respond with a buildkey. + +=item load + +Respond with CPU load based on a computation upon /proc/loadavg. + +=item currentauth + +Reply with current authentication information (only over an +encrypted channel). + +=item auth + +Only over an encrypted channel, reply as to whether a user's +authentication information can be validated. + +=item passwd + +Allow for a password to be set. + +=item makeuser + +Make a user. + +=item passwd + +Allow for authentication mechanism and password to be changed. + +=item home + +Respond to a question "are you the home for a given user?" + +=item update + +Update contents of a subscribed resource. + +=item unsubscribe + +The server is unsubscribing from a resource. + +=item subscribe + +The server is subscribing to a resource. + +=item log + +Place in B + +=item put + +stores hash in namespace + +=item rolesput + +put a role into a user's environment + +=item get + +returns hash with keys from array +reference filled in from namespace + +=item eget + +returns hash with keys from array +reference filled in from namesp (encrypts the return communication) + +=item rolesget + +get a role from a user's environment + +=item del + +deletes keys out of array from namespace + +=item keys + +returns namespace keys + +=item dump + +dumps the complete (or key matching regexp) namespace into a hash + +=item store + +stores hash permanently +for this url; hashref needs to be given and should be a \%hashname; the +remaining args aren't required and if they aren't passed or are '' they will +be derived from the ENV + +=item restore + +returns a hash for a given url + +=item querysend + +Tells client about the lonsql process that has been launched in response +to a sent query. + +=item queryreply + +Accept information from lonsql and make appropriate storage in temporary +file space. + +=item idput + +Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers +for each student, defined perhaps by the institutional Registrar.) + +=item idget + +Returns usernames corresponding to IDs. (These "IDs" are unique identifiers +for each student, defined perhaps by the institutional Registrar.) + +=item tmpput + +Accept and store information in temporary space. + +=item tmpget + +Send along temporarily stored information. + +=item ls + +List part of a user's directory. + +=item pushtable + +Pushes a file in /home/httpd/lonTab directory. Currently limited to: +hosts.tab and domain.tab. The old file is copied to *.tab.backup but +must be restored manually in case of a problem with the new table file. +pushtable requires that the request be encrypted and validated via +ValidateManager. The form of the command is: +enc:pushtable tablename \n +where pushtable, tablename and will be encrypted, but \n is a +cleartext newline. + +=item Hanging up (exit or init) + +What to do when a client tells the server that they (the client) +are leaving the network. + +=item unknown command + +If B is sent an unknown command (not in the list above), +it replys to the client "unknown_cmd". + + +=item UNKNOWN CLIENT + +If the anti-spoofing algorithm cannot verify the client, +the client is rejected (with a "refused" message sent +to the client, and the connection is closed. + +=back + +=head1 PREREQUISITES + +IO::Socket +IO::File +Apache::File +Symbol +POSIX +Crypt::IDEA +LWP::UserAgent() +GDBM_File +Authen::Krb4 +Authen::Krb5 + +=head1 COREQUISITES + +=head1 OSNAMES +linux +=head1 SCRIPT CATEGORIES +Server/Process +=cut