Annotation of loncom/lond, revision 1.212

1.1       albertel    1: #!/usr/bin/perl
                      2: # The LearningOnline Network
                      3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60      www         4: #
1.212   ! foxr        5: # $Id: lond,v 1.211 2004/07/23 16:14:19 albertel Exp $
1.60      www         6: #
                      7: # Copyright Michigan State University Board of Trustees
                      8: #
                      9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                     10: #
                     11: # LON-CAPA is free software; you can redistribute it and/or modify
                     12: # it under the terms of the GNU General Public License as published by
1.167     foxr       13: # the Free Software Foundation; either version 2 of the License, or 
1.60      www        14: # (at your option) any later version.
                     15: #
                     16: # LON-CAPA is distributed in the hope that it will be useful,
                     17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     19: # GNU General Public License for more details.
                     20: #
                     21: # You should have received a copy of the GNU General Public License
                     22: # along with LON-CAPA; if not, write to the Free Software
1.178     foxr       23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
1.60      www        24: #
                     25: # /home/httpd/html/adm/gpl.txt
                     26: #
1.161     foxr       27: 
                     28: 
1.60      www        29: # http://www.lon-capa.org/
                     30: #
1.54      harris41   31: 
1.134     albertel   32: use strict;
1.80      harris41   33: use lib '/home/httpd/lib/perl/';
                     34: use LONCAPA::Configuration;
                     35: 
1.1       albertel   36: use IO::Socket;
                     37: use IO::File;
1.126     albertel   38: #use Apache::File;
1.1       albertel   39: use Symbol;
                     40: use POSIX;
                     41: use Crypt::IDEA;
                     42: use LWP::UserAgent();
1.3       www        43: use GDBM_File;
                     44: use Authen::Krb4;
1.91      albertel   45: use Authen::Krb5;
1.49      albertel   46: use lib '/home/httpd/lib/perl/';
                     47: use localauth;
1.193     raeburn    48: use localenroll;
1.143     foxr       49: use File::Copy;
1.169     foxr       50: use LONCAPA::ConfigFileEdit;
1.200     matthew    51: use LONCAPA::lonlocal;
                     52: use LONCAPA::lonssl;
1.1       albertel   53: 
1.204     albertel   54: my $DEBUG = 0;		       # Non zero to enable debug log entries.
1.77      foxr       55: 
1.57      www        56: my $status='';
                     57: my $lastlog='';
                     58: 
1.212   ! foxr       59: my $VERSION='$Revision: 1.211 $'; #' stupid emacs
1.121     albertel   60: my $remoteVERSION;
1.115     albertel   61: my $currenthostid;
                     62: my $currentdomainid;
1.134     albertel   63: 
                     64: my $client;
1.200     matthew    65: my $clientip;			# IP address of client.
                     66: my $clientdns;			# DNS name of client.
                     67: my $clientname;			# LonCAPA name of client.
1.140     foxr       68: 
1.134     albertel   69: my $server;
1.200     matthew    70: my $thisserver;			# DNS of us.
                     71: 
                     72: my $keymode;
1.198     foxr       73: 
1.207     foxr       74: my $cipher;			# Cipher key negotiated with client
                     75: my $tmpsnum = 0;		# Id of tmpputs.
                     76: 
1.178     foxr       77: # 
                     78: #   Connection type is:
                     79: #      client                   - All client actions are allowed
                     80: #      manager                  - only management functions allowed.
                     81: #      both                     - Both management and client actions are allowed
                     82: #
1.161     foxr       83: 
1.178     foxr       84: my $ConnectionType;
1.161     foxr       85: 
1.200     matthew    86: my %hostid;			# ID's for hosts in cluster by ip.
                     87: my %hostdom;			# LonCAPA domain for hosts in cluster.
                     88: my %hostip;			# IPs for hosts in cluster.
                     89: my %hostdns;			# ID's of hosts looked up by DNS name.
1.161     foxr       90: 
1.178     foxr       91: my %managers;			# Ip -> manager names
1.161     foxr       92: 
1.178     foxr       93: my %perlvar;			# Will have the apache conf defined perl vars.
1.134     albertel   94: 
1.178     foxr       95: #
1.207     foxr       96: #   The hash below is used for command dispatching, and is therefore keyed on the request keyword.
                     97: #    Each element of the hash contains a reference to an array that contains:
                     98: #          A reference to a sub that executes the request corresponding to the keyword.
                     99: #          A flag that is true if the request must be encoded to be acceptable.
                    100: #          A mask with bits as follows:
                    101: #                      CLIENT_OK    - Set when the function is allowed by ordinary clients
                    102: #                      MANAGER_OK   - Set when the function is allowed to manager clients.
                    103: #
                    104: my $CLIENT_OK  = 1;
                    105: my $MANAGER_OK = 2;
                    106: my %Dispatcher;
                    107: 
                    108: 
                    109: #
1.178     foxr      110: #  The array below are password error strings."
                    111: #
                    112: my $lastpwderror    = 13;		# Largest error number from lcpasswd.
                    113: my @passwderrors = ("ok",
                    114: 		   "lcpasswd must be run as user 'www'",
                    115: 		   "lcpasswd got incorrect number of arguments",
                    116: 		   "lcpasswd did not get the right nubmer of input text lines",
                    117: 		   "lcpasswd too many simultaneous pwd changes in progress",
                    118: 		   "lcpasswd User does not exist.",
                    119: 		   "lcpasswd Incorrect current passwd",
                    120: 		   "lcpasswd Unable to su to root.",
                    121: 		   "lcpasswd Cannot set new passwd.",
                    122: 		   "lcpasswd Username has invalid characters",
                    123: 		   "lcpasswd Invalid characters in password",
                    124: 		    "11", "12",
                    125: 		    "lcpasswd Password mismatch");
1.97      foxr      126: 
                    127: 
1.178     foxr      128: #  The array below are lcuseradd error strings.:
1.97      foxr      129: 
1.178     foxr      130: my $lastadderror = 13;
                    131: my @adderrors    = ("ok",
                    132: 		    "User ID mismatch, lcuseradd must run as user www",
                    133: 		    "lcuseradd Incorrect number of command line parameters must be 3",
                    134: 		    "lcuseradd Incorrect number of stdinput lines, must be 3",
                    135: 		    "lcuseradd Too many other simultaneous pwd changes in progress",
                    136: 		    "lcuseradd User does not exist",
                    137: 		    "lcuseradd Unable to make www member of users's group",
                    138: 		    "lcuseradd Unable to su to root",
                    139: 		    "lcuseradd Unable to set password",
                    140: 		    "lcuseradd Usrname has invalid characters",
                    141: 		    "lcuseradd Password has an invalid character",
                    142: 		    "lcuseradd User already exists",
                    143: 		    "lcuseradd Could not add user.",
                    144: 		    "lcuseradd Password mismatch");
1.97      foxr      145: 
1.96      foxr      146: 
1.207     foxr      147: 
                    148: #
                    149: #   Statistics that are maintained and dislayed in the status line.
                    150: #
1.212   ! foxr      151: my $Transactions = 0;		# Number of attempted transactions.
        !           152: my $Failures     = 0;		# Number of transcations failed.
1.207     foxr      153: 
                    154: #   ResetStatistics: 
                    155: #      Resets the statistics counters:
                    156: #
                    157: sub ResetStatistics {
                    158:     $Transactions = 0;
                    159:     $Failures     = 0;
                    160: }
                    161: 
                    162: 
                    163: 
1.200     matthew   164: #------------------------------------------------------------------------
                    165: #
                    166: #   LocalConnection
                    167: #     Completes the formation of a locally authenticated connection.
                    168: #     This function will ensure that the 'remote' client is really the
                    169: #     local host.  If not, the connection is closed, and the function fails.
                    170: #     If so, initcmd is parsed for the name of a file containing the
                    171: #     IDEA session key.  The fie is opened, read, deleted and the session
                    172: #     key returned to the caller.
                    173: #
                    174: # Parameters:
                    175: #   $Socket      - Socket open on client.
                    176: #   $initcmd     - The full text of the init command.
                    177: #
                    178: # Implicit inputs:
                    179: #    $clientdns  - The DNS name of the remote client.
                    180: #    $thisserver - Our DNS name.
                    181: #
                    182: # Returns:
                    183: #     IDEA session key on success.
                    184: #     undef on failure.
                    185: #
                    186: sub LocalConnection {
                    187:     my ($Socket, $initcmd) = @_;
                    188:     Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");
                    189:     if($clientdns ne $thisserver) {
                    190: 	&logthis('<font color="red"> LocalConnection rejecting non local: '
                    191: 		 ."$clientdns ne $thisserver </font>");
                    192: 	close $Socket;
                    193: 	return undef;
                    194:     } 
                    195:     else {
                    196: 	chomp($initcmd);	# Get rid of \n in filename.
                    197: 	my ($init, $type, $name) = split(/:/, $initcmd);
                    198: 	Debug(" Init command: $init $type $name ");
                    199: 
                    200: 	# Require that $init = init, and $type = local:  Otherwise
                    201: 	# the caller is insane:
                    202: 
                    203: 	if(($init ne "init") && ($type ne "local")) {
                    204: 	    &logthis('<font color = "red"> LocalConnection: caller is insane! '
                    205: 		     ."init = $init, and type = $type </font>");
                    206: 	    close($Socket);;
                    207: 	    return undef;
                    208: 		
                    209: 	}
                    210: 	#  Now get the key filename:
                    211: 
                    212: 	my $IDEAKey = lonlocal::ReadKeyFile($name);
                    213: 	return $IDEAKey;
                    214:     }
                    215: }
                    216: #------------------------------------------------------------------------------
                    217: #
                    218: #  SSLConnection
                    219: #   Completes the formation of an ssh authenticated connection. The
                    220: #   socket is promoted to an ssl socket.  If this promotion and the associated
                    221: #   certificate exchange are successful, the IDEA key is generated and sent
                    222: #   to the remote peer via the SSL tunnel. The IDEA key is also returned to
                    223: #   the caller after the SSL tunnel is torn down.
                    224: #
                    225: # Parameters:
                    226: #   Name              Type             Purpose
                    227: #   $Socket          IO::Socket::INET  Plaintext socket.
                    228: #
                    229: # Returns:
                    230: #    IDEA key on success.
                    231: #    undef on failure.
                    232: #
                    233: sub SSLConnection {
                    234:     my $Socket   = shift;
                    235: 
                    236:     Debug("SSLConnection: ");
                    237:     my $KeyFile         = lonssl::KeyFile();
                    238:     if(!$KeyFile) {
                    239: 	my $err = lonssl::LastError();
                    240: 	&logthis("<font color=\"red\"> CRITICAL"
                    241: 		 ."Can't get key file $err </font>");
                    242: 	return undef;
                    243:     }
                    244:     my ($CACertificate,
                    245: 	$Certificate) = lonssl::CertificateFile();
                    246: 
                    247: 
                    248:     # If any of the key, certificate or certificate authority 
                    249:     # certificate filenames are not defined, this can't work.
                    250: 
                    251:     if((!$Certificate) || (!$CACertificate)) {
                    252: 	my $err = lonssl::LastError();
                    253: 	&logthis("<font color=\"red\"> CRITICAL"
                    254: 		 ."Can't get certificates: $err </font>");
                    255: 
                    256: 	return undef;
                    257:     }
                    258:     Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate");
                    259: 
                    260:     # Indicate to our peer that we can procede with
                    261:     # a transition to ssl authentication:
                    262: 
                    263:     print $Socket "ok:ssl\n";
                    264: 
                    265:     Debug("Approving promotion -> ssl");
                    266:     #  And do so:
                    267: 
                    268:     my $SSLSocket = lonssl::PromoteServerSocket($Socket,
                    269: 						$CACertificate,
                    270: 						$Certificate,
                    271: 						$KeyFile);
                    272:     if(! ($SSLSocket) ) {	# SSL socket promotion failed.
                    273: 	my $err = lonssl::LastError();
                    274: 	&logthis("<font color=\"red\"> CRITICAL "
                    275: 		 ."SSL Socket promotion failed: $err </font>");
                    276: 	return undef;
                    277:     }
                    278:     Debug("SSL Promotion successful");
                    279: 
                    280:     # 
                    281:     #  The only thing we'll use the socket for is to send the IDEA key
                    282:     #  to the peer:
                    283: 
                    284:     my $Key = lonlocal::CreateCipherKey();
                    285:     print $SSLSocket "$Key\n";
                    286: 
                    287:     lonssl::Close($SSLSocket); 
                    288: 
                    289:     Debug("Key exchange complete: $Key");
                    290: 
                    291:     return $Key;
                    292: }
                    293: #
                    294: #     InsecureConnection: 
                    295: #        If insecure connections are allowd,
                    296: #        exchange a challenge with the client to 'validate' the
                    297: #        client (not really, but that's the protocol):
                    298: #        We produce a challenge string that's sent to the client.
                    299: #        The client must then echo the challenge verbatim to us.
                    300: #
                    301: #  Parameter:
                    302: #      Socket      - Socket open on the client.
                    303: #  Returns:
                    304: #      1           - success.
                    305: #      0           - failure (e.g.mismatch or insecure not allowed).
                    306: #
                    307: sub InsecureConnection {
                    308:     my $Socket  =  shift;
                    309: 
                    310:     #   Don't even start if insecure connections are not allowed.
                    311: 
                    312:     if(! $perlvar{londAllowInsecure}) {	# Insecure connections not allowed.
                    313: 	return 0;
                    314:     }
                    315: 
                    316:     #   Fabricate a challenge string and send it..
                    317: 
                    318:     my $challenge = "$$".time;	# pid + time.
                    319:     print $Socket "$challenge\n";
                    320:     &status("Waiting for challenge reply");
                    321: 
                    322:     my $answer = <$Socket>;
                    323:     $answer    =~s/\W//g;
                    324:     if($challenge eq $answer) {
                    325: 	return 1;
                    326:     } 
                    327:     else {
                    328: 	logthis("<font color='blue'>WARNING client did not respond to challenge</font>");
                    329: 	&status("No challenge reqply");
                    330: 	return 0;
                    331:     }
                    332:     
                    333: 
                    334: }
                    335: 
1.96      foxr      336: #
1.140     foxr      337: #   GetCertificate: Given a transaction that requires a certificate,
                    338: #   this function will extract the certificate from the transaction
                    339: #   request.  Note that at this point, the only concept of a certificate
                    340: #   is the hostname to which we are connected.
                    341: #
                    342: #   Parameter:
                    343: #      request   - The request sent by our client (this parameterization may
                    344: #                  need to change when we really use a certificate granting
                    345: #                  authority.
                    346: #
                    347: sub GetCertificate {
                    348:     my $request = shift;
                    349: 
                    350:     return $clientip;
                    351: }
1.161     foxr      352: 
1.178     foxr      353: #
                    354: #   Return true if client is a manager.
                    355: #
                    356: sub isManager {
                    357:     return (($ConnectionType eq "manager") || ($ConnectionType eq "both"));
                    358: }
                    359: #
                    360: #   Return tru if client can do client functions
                    361: #
                    362: sub isClient {
                    363:     return (($ConnectionType eq "client") || ($ConnectionType eq "both"));
                    364: }
1.161     foxr      365: 
                    366: 
1.156     foxr      367: #
                    368: #   ReadManagerTable: Reads in the current manager table. For now this is
                    369: #                     done on each manager authentication because:
                    370: #                     - These authentications are not frequent
                    371: #                     - This allows dynamic changes to the manager table
                    372: #                       without the need to signal to the lond.
                    373: #
                    374: 
                    375: sub ReadManagerTable {
                    376: 
                    377:     #   Clean out the old table first..
                    378: 
1.166     foxr      379:    foreach my $key (keys %managers) {
                    380:       delete $managers{$key};
                    381:    }
                    382: 
                    383:    my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
                    384:    if (!open (MANAGERS, $tablename)) {
                    385:       logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
                    386:       return;
                    387:    }
                    388:    while(my $host = <MANAGERS>) {
                    389:       chomp($host);
                    390:       if ($host =~ "^#") {                  # Comment line.
                    391:          next;
                    392:       }
                    393:       if (!defined $hostip{$host}) { # This is a non cluster member
1.161     foxr      394: 	    #  The entry is of the form:
                    395: 	    #    cluname:hostname
                    396: 	    #  cluname - A 'cluster hostname' is needed in order to negotiate
                    397: 	    #            the host key.
                    398: 	    #  hostname- The dns name of the host.
                    399: 	    #
1.166     foxr      400:           my($cluname, $dnsname) = split(/:/, $host);
                    401:           
                    402:           my $ip = gethostbyname($dnsname);
                    403:           if(defined($ip)) {                 # bad names don't deserve entry.
                    404:             my $hostip = inet_ntoa($ip);
                    405:             $managers{$hostip} = $cluname;
                    406:             logthis('<font color="green"> registering manager '.
                    407:                     "$dnsname as $cluname with $hostip </font>\n");
                    408:          }
                    409:       } else {
                    410:          logthis('<font color="green"> existing host'." $host</font>\n");
                    411:          $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber
                    412:       }
                    413:    }
1.156     foxr      414: }
1.140     foxr      415: 
                    416: #
                    417: #  ValidManager: Determines if a given certificate represents a valid manager.
                    418: #                in this primitive implementation, the 'certificate' is
                    419: #                just the connecting loncapa client name.  This is checked
                    420: #                against a valid client list in the configuration.
                    421: #
                    422: #                  
                    423: sub ValidManager {
                    424:     my $certificate = shift; 
                    425: 
1.163     foxr      426:     return isManager;
1.140     foxr      427: }
                    428: #
1.143     foxr      429: #  CopyFile:  Called as part of the process of installing a 
                    430: #             new configuration file.  This function copies an existing
                    431: #             file to a backup file.
                    432: # Parameters:
                    433: #     oldfile  - Name of the file to backup.
                    434: #     newfile  - Name of the backup file.
                    435: # Return:
                    436: #     0   - Failure (errno has failure reason).
                    437: #     1   - Success.
                    438: #
                    439: sub CopyFile {
1.192     foxr      440: 
                    441:     my ($oldfile, $newfile) = @_;
1.143     foxr      442: 
                    443:     #  The file must exist:
                    444: 
                    445:     if(-e $oldfile) {
                    446: 
                    447: 	 # Read the old file.
                    448: 
                    449: 	my $oldfh = IO::File->new("< $oldfile");
                    450: 	if(!$oldfh) {
                    451: 	    return 0;
                    452: 	}
                    453: 	my @contents = <$oldfh>;  # Suck in the entire file.
                    454: 
                    455: 	# write the backup file:
                    456: 
                    457: 	my $newfh = IO::File->new("> $newfile");
                    458: 	if(!(defined $newfh)){
                    459: 	    return 0;
                    460: 	}
                    461: 	my $lines = scalar @contents;
                    462: 	for (my $i =0; $i < $lines; $i++) {
                    463: 	    print $newfh ($contents[$i]);
                    464: 	}
                    465: 
                    466: 	$oldfh->close;
                    467: 	$newfh->close;
                    468: 
                    469: 	chmod(0660, $newfile);
                    470: 
                    471: 	return 1;
                    472: 	    
                    473:     } else {
                    474: 	return 0;
                    475:     }
                    476: }
1.157     foxr      477: #
                    478: #  Host files are passed out with externally visible host IPs.
                    479: #  If, for example, we are behind a fire-wall or NAT host, our 
                    480: #  internally visible IP may be different than the externally
                    481: #  visible IP.  Therefore, we always adjust the contents of the
                    482: #  host file so that the entry for ME is the IP that we believe
                    483: #  we have.  At present, this is defined as the entry that
                    484: #  DNS has for us.  If by some chance we are not able to get a
                    485: #  DNS translation for us, then we assume that the host.tab file
                    486: #  is correct.  
                    487: #    BUGBUGBUG - in the future, we really should see if we can
                    488: #       easily query the interface(s) instead.
                    489: # Parameter(s):
                    490: #     contents    - The contents of the host.tab to check.
                    491: # Returns:
                    492: #     newcontents - The adjusted contents.
                    493: #
                    494: #
                    495: sub AdjustHostContents {
                    496:     my $contents  = shift;
                    497:     my $adjusted;
                    498:     my $me        = $perlvar{'lonHostID'};
                    499: 
1.166     foxr      500:  foreach my $line (split(/\n/,$contents)) {
1.157     foxr      501: 	if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
                    502: 	    chomp($line);
                    503: 	    my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
                    504: 	    if ($id eq $me) {
1.166     foxr      505:           my $ip = gethostbyname($name);
                    506:           my $ipnew = inet_ntoa($ip);
                    507:          $ip = $ipnew;
1.157     foxr      508: 		#  Reconstruct the host line and append to adjusted:
                    509: 		
1.166     foxr      510: 		   my $newline = "$id:$domain:$role:$name:$ip";
                    511: 		   if($maxcon ne "") { # Not all hosts have loncnew tuning params
                    512: 		     $newline .= ":$maxcon:$idleto:$mincon";
                    513: 		   }
                    514: 		   $adjusted .= $newline."\n";
1.157     foxr      515: 		
1.166     foxr      516:       } else {		# Not me, pass unmodified.
                    517: 		   $adjusted .= $line."\n";
                    518:       }
1.157     foxr      519: 	} else {                  # Blank or comment never re-written.
                    520: 	    $adjusted .= $line."\n";	# Pass blanks and comments as is.
                    521: 	}
1.166     foxr      522:  }
                    523:  return $adjusted;
1.157     foxr      524: }
1.143     foxr      525: #
                    526: #   InstallFile: Called to install an administrative file:
                    527: #       - The file is created with <name>.tmp
                    528: #       - The <name>.tmp file is then mv'd to <name>
                    529: #   This lugubrious procedure is done to ensure that we are never without
                    530: #   a valid, even if dated, version of the file regardless of who crashes
                    531: #   and when the crash occurs.
                    532: #
                    533: #  Parameters:
                    534: #       Name of the file
                    535: #       File Contents.
                    536: #  Return:
                    537: #      nonzero - success.
                    538: #      0       - failure and $! has an errno.
                    539: #
                    540: sub InstallFile {
1.192     foxr      541: 
                    542:     my ($Filename, $Contents) = @_;
1.143     foxr      543:     my $TempFile = $Filename.".tmp";
                    544: 
                    545:     #  Open the file for write:
                    546: 
                    547:     my $fh = IO::File->new("> $TempFile"); # Write to temp.
                    548:     if(!(defined $fh)) {
                    549: 	&logthis('<font color="red"> Unable to create '.$TempFile."</font>");
                    550: 	return 0;
                    551:     }
                    552:     #  write the contents of the file:
                    553: 
                    554:     print $fh ($Contents); 
                    555:     $fh->close;			# In case we ever have a filesystem w. locking
                    556: 
                    557:     chmod(0660, $TempFile);
                    558: 
                    559:     # Now we can move install the file in position.
                    560:     
                    561:     move($TempFile, $Filename);
                    562: 
                    563:     return 1;
                    564: }
1.200     matthew   565: 
                    566: 
1.169     foxr      567: #
                    568: #   ConfigFileFromSelector: converts a configuration file selector
                    569: #                 (one of host or domain at this point) into a 
                    570: #                 configuration file pathname.
                    571: #
                    572: #  Parameters:
                    573: #      selector  - Configuration file selector.
                    574: #  Returns:
                    575: #      Full path to the file or undef if the selector is invalid.
                    576: #
                    577: sub ConfigFileFromSelector {
                    578:     my $selector   = shift;
                    579:     my $tablefile;
                    580: 
                    581:     my $tabledir = $perlvar{'lonTabDir'}.'/';
                    582:     if ($selector eq "hosts") {
                    583: 	$tablefile = $tabledir."hosts.tab";
                    584:     } elsif ($selector eq "domain") {
                    585: 	$tablefile = $tabledir."domain.tab";
                    586:     } else {
                    587: 	return undef;
                    588:     }
                    589:     return $tablefile;
1.143     foxr      590: 
1.169     foxr      591: }
1.143     foxr      592: #
1.141     foxr      593: #   PushFile:  Called to do an administrative push of a file.
                    594: #              - Ensure the file being pushed is one we support.
                    595: #              - Backup the old file to <filename.saved>
                    596: #              - Separate the contents of the new file out from the
                    597: #                rest of the request.
                    598: #              - Write the new file.
                    599: #  Parameter:
                    600: #     Request - The entire user request.  This consists of a : separated
                    601: #               string pushfile:tablename:contents.
                    602: #     NOTE:  The contents may have :'s in it as well making things a bit
                    603: #            more interesting... but not much.
                    604: #  Returns:
                    605: #     String to send to client ("ok" or "refused" if bad file).
                    606: #
                    607: sub PushFile {
                    608:     my $request = shift;    
                    609:     my ($command, $filename, $contents) = split(":", $request, 3);
                    610:     
                    611:     #  At this point in time, pushes for only the following tables are
                    612:     #  supported:
                    613:     #   hosts.tab  ($filename eq host).
                    614:     #   domain.tab ($filename eq domain).
                    615:     # Construct the destination filename or reject the request.
                    616:     #
                    617:     # lonManage is supposed to ensure this, however this session could be
                    618:     # part of some elaborate spoof that managed somehow to authenticate.
                    619:     #
                    620: 
1.169     foxr      621: 
                    622:     my $tablefile = ConfigFileFromSelector($filename);
                    623:     if(! (defined $tablefile)) {
1.141     foxr      624: 	return "refused";
                    625:     }
                    626:     #
                    627:     # >copy< the old table to the backup table
                    628:     #        don't rename in case system crashes/reboots etc. in the time
                    629:     #        window between a rename and write.
                    630:     #
                    631:     my $backupfile = $tablefile;
                    632:     $backupfile    =~ s/\.tab$/.old/;
1.143     foxr      633:     if(!CopyFile($tablefile, $backupfile)) {
                    634: 	&logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
                    635: 	return "error:$!";
                    636:     }
1.141     foxr      637:     &logthis('<font color="green"> Pushfile: backed up '
                    638: 	    .$tablefile." to $backupfile</font>");
                    639:     
1.157     foxr      640:     #  If the file being pushed is the host file, we adjust the entry for ourself so that the
                    641:     #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible
                    642:     #  to conceive of conditions where we don't have a DNS entry locally.  This is possible in a 
                    643:     #  network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now)
                    644:     #  that possibilty.
                    645: 
                    646:     if($filename eq "host") {
                    647: 	$contents = AdjustHostContents($contents);
                    648:     }
                    649: 
1.141     foxr      650:     #  Install the new file:
                    651: 
1.143     foxr      652:     if(!InstallFile($tablefile, $contents)) {
                    653: 	&logthis('<font color="red"> Pushfile: unable to install '
1.145     foxr      654: 	 .$tablefile." $! </font>");
1.143     foxr      655: 	return "error:$!";
                    656:     }
                    657:     else {
                    658: 	&logthis('<font color="green"> Installed new '.$tablefile
                    659: 		 ."</font>");
                    660: 
                    661:     }
                    662: 
1.141     foxr      663: 
                    664:     #  Indicate success:
                    665:  
                    666:     return "ok";
                    667: 
                    668: }
1.145     foxr      669: 
                    670: #
                    671: #  Called to re-init either lonc or lond.
                    672: #
                    673: #  Parameters:
                    674: #    request   - The full request by the client.  This is of the form
                    675: #                reinit:<process>  
                    676: #                where <process> is allowed to be either of 
                    677: #                lonc or lond
                    678: #
                    679: #  Returns:
                    680: #     The string to be sent back to the client either:
                    681: #   ok         - Everything worked just fine.
                    682: #   error:why  - There was a failure and why describes the reason.
                    683: #
                    684: #
                    685: sub ReinitProcess {
                    686:     my $request = shift;
                    687: 
1.146     foxr      688: 
                    689:     # separate the request (reinit) from the process identifier and
                    690:     # validate it producing the name of the .pid file for the process.
                    691:     #
                    692:     #
                    693:     my ($junk, $process) = split(":", $request);
1.147     foxr      694:     my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
1.146     foxr      695:     if($process eq 'lonc') {
                    696: 	$processpidfile = $processpidfile."lonc.pid";
1.147     foxr      697: 	if (!open(PIDFILE, "< $processpidfile")) {
                    698: 	    return "error:Open failed for $processpidfile";
                    699: 	}
                    700: 	my $loncpid = <PIDFILE>;
                    701: 	close(PIDFILE);
                    702: 	logthis('<font color="red"> Reinitializing lonc pid='.$loncpid
                    703: 		."</font>");
                    704: 	kill("USR2", $loncpid);
1.146     foxr      705:     } elsif ($process eq 'lond') {
1.147     foxr      706: 	logthis('<font color="red"> Reinitializing self (lond) </font>');
                    707: 	&UpdateHosts;			# Lond is us!!
1.146     foxr      708:     } else {
                    709: 	&logthis('<font color="yellow" Invalid reinit request for '.$process
                    710: 		 ."</font>");
                    711: 	return "error:Invalid process identifier $process";
                    712:     }
1.145     foxr      713:     return 'ok';
                    714: }
1.168     foxr      715: #   Validate a line in a configuration file edit script:
                    716: #   Validation includes:
                    717: #     - Ensuring the command is valid.
                    718: #     - Ensuring the command has sufficient parameters
                    719: #   Parameters:
                    720: #     scriptline - A line to validate (\n has been stripped for what it's worth).
1.167     foxr      721: #
1.168     foxr      722: #   Return:
                    723: #      0     - Invalid scriptline.
                    724: #      1     - Valid scriptline
                    725: #  NOTE:
                    726: #     Only the command syntax is checked, not the executability of the
                    727: #     command.
                    728: #
                    729: sub isValidEditCommand {
                    730:     my $scriptline = shift;
                    731: 
                    732:     #   Line elements are pipe separated:
                    733: 
                    734:     my ($command, $key, $newline)  = split(/\|/, $scriptline);
                    735:     &logthis('<font color="green"> isValideditCommand checking: '.
                    736: 	     "Command = '$command', Key = '$key', Newline = '$newline' </font>\n");
                    737:     
                    738:     if ($command eq "delete") {
                    739: 	#
                    740: 	#   key with no newline.
                    741: 	#
                    742: 	if( ($key eq "") || ($newline ne "")) {
                    743: 	    return 0;		# Must have key but no newline.
                    744: 	} else {
                    745: 	    return 1;		# Valid syntax.
                    746: 	}
1.169     foxr      747:     } elsif ($command eq "replace") {
1.168     foxr      748: 	#
                    749: 	#   key and newline:
                    750: 	#
                    751: 	if (($key eq "") || ($newline eq "")) {
                    752: 	    return 0;
                    753: 	} else {
                    754: 	    return 1;
                    755: 	}
1.169     foxr      756:     } elsif ($command eq "append") {
                    757: 	if (($key ne "") && ($newline eq "")) {
                    758: 	    return 1;
                    759: 	} else {
                    760: 	    return 0;
                    761: 	}
1.168     foxr      762:     } else {
                    763: 	return 0;		# Invalid command.
                    764:     }
                    765:     return 0;			# Should not get here!!!
                    766: }
1.169     foxr      767: #
                    768: #   ApplyEdit - Applies an edit command to a line in a configuration 
                    769: #               file.  It is the caller's responsiblity to validate the
                    770: #               edit line.
                    771: #   Parameters:
                    772: #      $directive - A single edit directive to apply.  
                    773: #                   Edit directives are of the form:
                    774: #                  append|newline      - Appends a new line to the file.
                    775: #                  replace|key|newline - Replaces the line with key value 'key'
                    776: #                  delete|key          - Deletes the line with key value 'key'.
                    777: #      $editor   - A config file editor object that contains the
                    778: #                  file being edited.
                    779: #
                    780: sub ApplyEdit {
1.192     foxr      781: 
                    782:     my ($directive, $editor) = @_;
1.169     foxr      783: 
                    784:     # Break the directive down into its command and its parameters
                    785:     # (at most two at this point.  The meaning of the parameters, if in fact
                    786:     #  they exist depends on the command).
                    787: 
                    788:     my ($command, $p1, $p2) = split(/\|/, $directive);
                    789: 
                    790:     if($command eq "append") {
                    791: 	$editor->Append($p1);	          # p1 - key p2 null.
                    792:     } elsif ($command eq "replace") {
                    793: 	$editor->ReplaceLine($p1, $p2);   # p1 - key p2 = newline.
                    794:     } elsif ($command eq "delete") {
                    795: 	$editor->DeleteLine($p1);         # p1 - key p2 null.
                    796:     } else {			          # Should not get here!!!
                    797: 	die "Invalid command given to ApplyEdit $command"
                    798:     }
                    799: }
                    800: #
                    801: # AdjustOurHost:
                    802: #           Adjusts a host file stored in a configuration file editor object
                    803: #           for the true IP address of this host. This is necessary for hosts
                    804: #           that live behind a firewall.
                    805: #           Those hosts have a publicly distributed IP of the firewall, but
                    806: #           internally must use their actual IP.  We assume that a given
                    807: #           host only has a single IP interface for now.
                    808: # Formal Parameters:
                    809: #     editor   - The configuration file editor to adjust.  This
                    810: #                editor is assumed to contain a hosts.tab file.
                    811: # Strategy:
                    812: #    - Figure out our hostname.
                    813: #    - Lookup the entry for this host.
                    814: #    - Modify the line to contain our IP
                    815: #    - Do a replace for this host.
                    816: sub AdjustOurHost {
                    817:     my $editor        = shift;
                    818: 
                    819:     # figure out who I am.
                    820: 
                    821:     my $myHostName    = $perlvar{'lonHostID'}; # LonCAPA hostname.
                    822: 
                    823:     #  Get my host file entry.
                    824: 
                    825:     my $ConfigLine    = $editor->Find($myHostName);
                    826:     if(! (defined $ConfigLine)) {
                    827: 	die "AdjustOurHost - no entry for me in hosts file $myHostName";
                    828:     }
                    829:     # figure out my IP:
                    830:     #   Use the config line to get my hostname.
                    831:     #   Use gethostbyname to translate that into an IP address.
                    832:     #
                    833:     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
                    834:     my $BinaryIp = gethostbyname($name);
                    835:     my $ip       = inet_ntoa($ip);
                    836:     #
                    837:     #  Reassemble the config line from the elements in the list.
                    838:     #  Note that if the loncnew items were not present before, they will
                    839:     #  be now even if they would be empty
                    840:     #
                    841:     my $newConfigLine = $id;
                    842:     foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {
                    843: 	$newConfigLine .= ":".$item;
                    844:     }
                    845:     #  Replace the line:
                    846: 
                    847:     $editor->ReplaceLine($id, $newConfigLine);
                    848:     
                    849: }
                    850: #
                    851: #   ReplaceConfigFile:
                    852: #              Replaces a configuration file with the contents of a
                    853: #              configuration file editor object.
                    854: #              This is done by:
                    855: #              - Copying the target file to <filename>.old
                    856: #              - Writing the new file to <filename>.tmp
                    857: #              - Moving <filename.tmp>  -> <filename>
                    858: #              This laborious process ensures that the system is never without
                    859: #              a configuration file that's at least valid (even if the contents
                    860: #              may be dated).
                    861: #   Parameters:
                    862: #        filename   - Name of the file to modify... this is a full path.
                    863: #        editor     - Editor containing the file.
                    864: #
                    865: sub ReplaceConfigFile {
1.192     foxr      866:     
                    867:     my ($filename, $editor) = @_;
1.168     foxr      868: 
1.169     foxr      869:     CopyFile ($filename, $filename.".old");
                    870: 
                    871:     my $contents  = $editor->Get(); # Get the contents of the file.
                    872: 
                    873:     InstallFile($filename, $contents);
                    874: }
1.168     foxr      875: #   
                    876: #
                    877: #   Called to edit a configuration table  file
1.167     foxr      878: #   Parameters:
                    879: #      request           - The entire command/request sent by lonc or lonManage
                    880: #   Return:
                    881: #      The reply to send to the client.
1.168     foxr      882: #
1.167     foxr      883: sub EditFile {
                    884:     my $request = shift;
                    885: 
                    886:     #  Split the command into it's pieces:  edit:filetype:script
                    887: 
1.168     foxr      888:     my ($request, $filetype, $script) = split(/:/, $request,3);	# : in script
1.167     foxr      889: 
                    890:     #  Check the pre-coditions for success:
                    891: 
                    892:     if($request != "edit") {	# Something is amiss afoot alack.
                    893: 	return "error:edit request detected, but request != 'edit'\n";
                    894:     }
                    895:     if( ($filetype ne "hosts")  &&
                    896: 	($filetype ne "domain")) {
                    897: 	return "error:edit requested with invalid file specifier: $filetype \n";
                    898:     }
                    899: 
                    900:     #   Split the edit script and check it's validity.
1.168     foxr      901: 
                    902:     my @scriptlines = split(/\n/, $script);  # one line per element.
                    903:     my $linecount   = scalar(@scriptlines);
                    904:     for(my $i = 0; $i < $linecount; $i++) {
                    905: 	chomp($scriptlines[$i]);
                    906: 	if(!isValidEditCommand($scriptlines[$i])) {
                    907: 	    return "error:edit with bad script line: '$scriptlines[$i]' \n";
                    908: 	}
                    909:     }
1.145     foxr      910: 
1.167     foxr      911:     #   Execute the edit operation.
1.169     foxr      912:     #   - Create a config file editor for the appropriate file and 
                    913:     #   - execute each command in the script:
                    914:     #
                    915:     my $configfile = ConfigFileFromSelector($filetype);
                    916:     if (!(defined $configfile)) {
                    917: 	return "refused\n";
                    918:     }
                    919:     my $editor = ConfigFileEdit->new($configfile);
1.167     foxr      920: 
1.169     foxr      921:     for (my $i = 0; $i < $linecount; $i++) {
                    922: 	ApplyEdit($scriptlines[$i], $editor);
                    923:     }
                    924:     # If the file is the host file, ensure that our host is
                    925:     # adjusted to have our ip:
                    926:     #
                    927:     if($filetype eq "host") {
                    928: 	AdjustOurHost($editor);
                    929:     }
                    930:     #  Finally replace the current file with our file.
                    931:     #
                    932:     ReplaceConfigFile($configfile, $editor);
1.167     foxr      933: 
                    934:     return "ok\n";
                    935: }
1.207     foxr      936: 
                    937: #---------------------------------------------------------------
                    938: #
                    939: # Manipulation of hash based databases (factoring out common code
                    940: # for later use as we refactor.
                    941: #
                    942: #  Ties a domain level resource file to a hash.
                    943: #  If requested a history entry is created in the associated hist file.
                    944: #
                    945: #  Parameters:
                    946: #     domain    - Name of the domain in which the resource file lives.
                    947: #     namespace - Name of the hash within that domain.
                    948: #     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
                    949: #     loghead   - Optional parameter, if present a log entry is created
                    950: #                 in the associated history file and this is the first part
                    951: #                  of that entry.
                    952: #     logtail   - Goes along with loghead,  The actual logentry is of the
                    953: #                 form $loghead:<timestamp>:logtail.
                    954: # Returns:
                    955: #    Reference to a hash bound to the db file or alternatively undef
                    956: #    if the tie failed.
                    957: #
1.209     albertel  958: sub tie_domain_hash {
1.210     albertel  959:     my ($domain,$namespace,$how,$loghead,$logtail) = @_;
1.207     foxr      960:     
                    961:     # Filter out any whitespace in the domain name:
                    962:     
                    963:     $domain =~ s/\W//g;
                    964:     
                    965:     # We have enough to go on to tie the hash:
                    966:     
                    967:     my $user_top_dir   = $perlvar{'lonUsersDir'};
                    968:     my $domain_dir     = $user_top_dir."/$domain";
                    969:     my $resource_file  = $domain_dir."/$namespace.db";
                    970:     my %hash;
                    971:     if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) {
1.211     albertel  972: 	if (defined($loghead)) {	# Need to log the operation.
1.210     albertel  973: 	    my $logFh = IO::File->new(">>$domain_dir/$namespace.hist");
1.207     foxr      974: 	    if($logFh) {
                    975: 		my $timestamp = time;
                    976: 		print $logFh "$loghead:$timestamp:$logtail\n";
                    977: 	    }
1.210     albertel  978: 	    $logFh->close;
1.207     foxr      979: 	}
                    980: 	return \%hash;		# Return the tied hash.
1.210     albertel  981:     } else {
1.207     foxr      982: 	return undef;		# Tie failed.
                    983:     }
                    984: }
                    985: 
                    986: #
                    987: #   Ties a user's resource file to a hash.  
                    988: #   If necessary, an appropriate history
                    989: #   log file entry is made as well.
                    990: #   This sub factors out common code from the subs that manipulate
                    991: #   the various gdbm files that keep keyword value pairs.
                    992: # Parameters:
                    993: #   domain       - Name of the domain the user is in.
                    994: #   user         - Name of the 'current user'.
                    995: #   namespace    - Namespace representing the file to tie.
                    996: #   how          - What the tie is done to (e.g. GDBM_WRCREAT().
                    997: #   loghead      - Optional first part of log entry if there may be a
                    998: #                  history file.
                    999: #   what         - Optional tail of log entry if there may be a history
                   1000: #                  file.
                   1001: # Returns:
                   1002: #   hash to which the database is tied.  It's up to the caller to untie.
                   1003: #   undef if the has could not be tied.
                   1004: #
1.210     albertel 1005: sub tie_user_hash {
                   1006:     my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
1.207     foxr     1007: 
                   1008:     $namespace=~s/\//\_/g;	# / -> _
                   1009:     $namespace=~s/\W//g;		# whitespace eliminated.
                   1010:     my $proname     = propath($domain, $user);
                   1011:    
                   1012:     #  Tie the database.
                   1013:     
                   1014:     my %hash;
                   1015:     if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
                   1016: 	   $how, 0640)) {
1.209     albertel 1017: 	# If this is a namespace for which a history is kept,
                   1018: 	# make the history log entry:    
1.211     albertel 1019: 	if (($namespace =~/^nohist\_/) && (defined($loghead))) {
1.209     albertel 1020: 	    my $args = scalar @_;
                   1021: 	    Debug(" Opening history: $namespace $args");
                   1022: 	    my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
                   1023: 	    if($hfh) {
                   1024: 		my $now = time;
                   1025: 		print $hfh "$loghead:$now:$what\n";
                   1026: 	    }
1.210     albertel 1027: 	    $hfh->close;
1.209     albertel 1028: 	}
1.207     foxr     1029: 	return \%hash;
1.209     albertel 1030:     } else {
1.207     foxr     1031: 	return undef;
                   1032:     }
                   1033:     
                   1034: }
                   1035: #---------------------------------------------------------------
                   1036: #
                   1037: #   Getting, decoding and dispatching requests:
                   1038: #
                   1039: 
                   1040: #
                   1041: #   Get a Request:
                   1042: #   Gets a Request message from the client.  The transaction
                   1043: #   is defined as a 'line' of text.  We remove the new line
                   1044: #   from the text line.  
                   1045: #   
1.211     albertel 1046: sub get_request {
1.207     foxr     1047:     my $input = <$client>;
                   1048:     chomp($input);
                   1049: 
1.212   ! foxr     1050:     Debug("get_request: Request = $input\n");
1.207     foxr     1051: 
                   1052:     &status('Processing '.$clientname.':'.$input);
                   1053: 
                   1054:     return $input;
                   1055: }
1.212   ! foxr     1056: #---------------------------------------------------------------
        !          1057: #
        !          1058: #  Process a request.  This sub should shrink as each action
        !          1059: #  gets farmed out into a separat sub that is registered 
        !          1060: #  with the dispatch hash.  
        !          1061: #
        !          1062: # Parameters:
        !          1063: #    user_input   - The request received from the client (lonc).
        !          1064: # Returns:
        !          1065: #    true to keep processing, false if caller should exit.
        !          1066: #
        !          1067: sub process_request {
        !          1068:     my ($userinput) = @_;      # Easier for now to break style than to
        !          1069:                                 # fix all the userinput -> user_input.
        !          1070:     my $wasenc    = 0;		# True if request was encrypted.
        !          1071: # ------------------------------------------------------------ See if encrypted
        !          1072:     if ($userinput =~ /^enc/) {
        !          1073: 	$userinput = decipher($userinput);
        !          1074: 	$wasenc=1;
        !          1075: 	if(!$userinput) {	# Cipher not defined.
        !          1076: 	    &Failure($client, "error: Encrypted data without negotated key");
        !          1077: 	    return 0;
        !          1078: 	}
        !          1079:     }
        !          1080:     Debug("process_request: $userinput\n");
        !          1081:     
        !          1082: # ------------------------------------------------------------- Normal commands
        !          1083: # ------------------------------------------------------------------------ ping
        !          1084:     if ($userinput =~ /^ping/) {	# client only
        !          1085: 	if(isClient) {
        !          1086: 	    print $client "$currenthostid\n";
        !          1087: 	} else {
        !          1088: 	    Reply($client, "refused\n", $userinput);
        !          1089: 	}
        !          1090: # ------------------------------------------------------------------------ pong
        !          1091:     }elsif ($userinput =~ /^pong/) { # client only
        !          1092: 	if(isClient) {
        !          1093: 	    my $reply=&reply("ping",$clientname);
        !          1094: 	    print $client "$currenthostid:$reply\n"; 
        !          1095: 	} else {
        !          1096: 	    Reply($client, "refused\n", $userinput);
        !          1097: 	}
        !          1098: # ------------------------------------------------------------------------ ekey
        !          1099:     } elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs
        !          1100: 	my $buildkey=time.$$.int(rand 100000);
        !          1101: 	$buildkey=~tr/1-6/A-F/;
        !          1102: 	$buildkey=int(rand 100000).$buildkey.int(rand 100000);
        !          1103: 	my $key=$currenthostid.$clientname;
        !          1104: 	$key=~tr/a-z/A-Z/;
        !          1105: 	$key=~tr/G-P/0-9/;
        !          1106: 	$key=~tr/Q-Z/0-9/;
        !          1107: 	$key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
        !          1108: 	$key=substr($key,0,32);
        !          1109: 	my $cipherkey=pack("H32",$key);
        !          1110: 	$cipher=new IDEA $cipherkey;
        !          1111: 	print $client "$buildkey\n"; 
        !          1112: # ------------------------------------------------------------------------ load
        !          1113:     } elsif ($userinput =~ /^load/) { # client only
        !          1114: 	if (isClient) {
        !          1115: 	    my $loadavg;
        !          1116: 	    {
        !          1117: 		my $loadfile=IO::File->new('/proc/loadavg');
        !          1118: 		$loadavg=<$loadfile>;
        !          1119: 	    }
        !          1120: 	    $loadavg =~ s/\s.*//g;
        !          1121: 	    my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
        !          1122: 	    print $client "$loadpercent\n";
        !          1123: 	} else {
        !          1124: 	    Reply($client, "refused\n", $userinput);
        !          1125: 	    
        !          1126: 	}
        !          1127: # -------------------------------------------------------------------- userload
        !          1128:     } elsif ($userinput =~ /^userload/) { # client only
        !          1129: 	if(isClient) {
        !          1130: 	    my $userloadpercent=&userload();
        !          1131: 	    print $client "$userloadpercent\n";
        !          1132: 	} else {
        !          1133: 	    Reply($client, "refused\n", $userinput);
        !          1134: 	    
        !          1135: 	}
        !          1136: #
        !          1137: #        Transactions requiring encryption:
        !          1138: #
        !          1139: # ----------------------------------------------------------------- currentauth
        !          1140:     } elsif ($userinput =~ /^currentauth/) {
        !          1141: 	if (($wasenc==1)  && isClient) { # Encoded & client only.
        !          1142: 	    my ($cmd,$udom,$uname)=split(/:/,$userinput);
        !          1143: 	    my $result = GetAuthType($udom, $uname);
        !          1144: 	    if($result eq "nouser") {
        !          1145: 		print $client "unknown_user\n";
        !          1146: 	    }
        !          1147: 	    else {
        !          1148: 		print $client "$result\n";
        !          1149: 	    }
        !          1150: 	} else {
        !          1151: 	    Reply($client, "refused\n", $userinput);
        !          1152: 	    
        !          1153: 	}
        !          1154: #--------------------------------------------------------------------- pushfile
        !          1155:     } elsif($userinput =~ /^pushfile/) {	# encoded & manager.
        !          1156: 	if(($wasenc == 1) && isManager) {
        !          1157: 	    my $cert = GetCertificate($userinput);
        !          1158: 	    if(ValidManager($cert)) {
        !          1159: 		my $reply = PushFile($userinput);
        !          1160: 		print $client "$reply\n";
        !          1161: 	    } else {
        !          1162: 		print $client "refused\n";
        !          1163: 	    } 
        !          1164: 	} else {
        !          1165: 	    Reply($client, "refused\n", $userinput);
        !          1166: 	    
        !          1167: 	}
        !          1168: #--------------------------------------------------------------------- reinit
        !          1169:     } elsif($userinput =~ /^reinit/) { # Encoded and manager
        !          1170: 	if (($wasenc == 1) && isManager) {
        !          1171: 	    my $cert = GetCertificate($userinput);
        !          1172: 	    if(ValidManager($cert)) {
        !          1173: 		chomp($userinput);
        !          1174: 		my $reply = ReinitProcess($userinput);
        !          1175: 		print $client  "$reply\n";
        !          1176: 	    } else {
        !          1177: 		print $client "refused\n";
        !          1178: 	    }
        !          1179: 	} else {
        !          1180: 	    Reply($client, "refused\n", $userinput);
        !          1181: 	}
        !          1182: #------------------------------------------------------------------------- edit
        !          1183:     } elsif ($userinput =~ /^edit/) {    # encoded and manager:
        !          1184: 	if(($wasenc ==1) && (isManager)) {
        !          1185: 	    my $cert = GetCertificate($userinput);
        !          1186: 	    if(ValidManager($cert)) {
        !          1187: 		my($command, $filetype, $script) = split(/:/, $userinput);
        !          1188: 		if (($filetype eq "hosts") || ($filetype eq "domain")) {
        !          1189: 		    if($script ne "") {
        !          1190: 			Reply($client, EditFile($userinput));
        !          1191: 		    } else {
        !          1192: 			Reply($client,"refused\n",$userinput);
        !          1193: 		    }
        !          1194: 		} else {
        !          1195: 		    Reply($client,"refused\n",$userinput);
        !          1196: 		}
        !          1197:             } else {
        !          1198: 		Reply($client,"refused\n",$userinput);
        !          1199:             }
        !          1200: 	} else {
        !          1201: 	    Reply($client,"refused\n",$userinput);
        !          1202: 	}
        !          1203: # ------------------------------------------------------------------------ auth
        !          1204:     } elsif ($userinput =~ /^auth/) { # Encoded and client only.
        !          1205: 	if (($wasenc==1) && isClient) {
        !          1206: 	    my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
        !          1207: 	    chomp($upass);
        !          1208: 	    $upass=unescape($upass);
        !          1209: 	    my $proname=propath($udom,$uname);
        !          1210: 	    my $passfilename="$proname/passwd";
        !          1211: 	    if (-e $passfilename) {
        !          1212: 		my $pf = IO::File->new($passfilename);
        !          1213: 		my $realpasswd=<$pf>;
        !          1214: 		chomp($realpasswd);
        !          1215: 		my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
        !          1216: 		my $pwdcorrect=0;
        !          1217: 		if ($howpwd eq 'internal') {
        !          1218: 		    &Debug("Internal auth");
        !          1219: 		    $pwdcorrect=
        !          1220: 			(crypt($upass,$contentpwd) eq $contentpwd);
        !          1221: 		} elsif ($howpwd eq 'unix') {
        !          1222: 		    &Debug("Unix auth");
        !          1223: 		    if((getpwnam($uname))[1] eq "") { #no such user!
        !          1224: 			$pwdcorrect = 0;
        !          1225: 		    } else {
        !          1226: 			$contentpwd=(getpwnam($uname))[1];
        !          1227: 			my $pwauth_path="/usr/local/sbin/pwauth";
        !          1228: 			unless ($contentpwd eq 'x') {
        !          1229: 			    $pwdcorrect=
        !          1230: 				(crypt($upass,$contentpwd) eq 
        !          1231: 				 $contentpwd);
        !          1232: 			}
        !          1233: 			
        !          1234: 			elsif (-e $pwauth_path) {
        !          1235: 			    open PWAUTH, "|$pwauth_path" or
        !          1236: 				die "Cannot invoke authentication";
        !          1237: 			    print PWAUTH "$uname\n$upass\n";
        !          1238: 			    close PWAUTH;
        !          1239: 			    $pwdcorrect=!$?;
        !          1240: 			}
        !          1241: 		    }
        !          1242: 		} elsif ($howpwd eq 'krb4') {
        !          1243: 		    my $null=pack("C",0);
        !          1244: 		    unless ($upass=~/$null/) {
        !          1245: 			my $krb4_error = &Authen::Krb4::get_pw_in_tkt
        !          1246: 			    ($uname,"",$contentpwd,'krbtgt',
        !          1247: 			     $contentpwd,1,$upass);
        !          1248: 			if (!$krb4_error) {
        !          1249: 			    $pwdcorrect = 1;
        !          1250: 			} else { 
        !          1251: 			    $pwdcorrect=0; 
        !          1252: 			    # log error if it is not a bad password
        !          1253: 			    if ($krb4_error != 62) {
        !          1254: 				&logthis('krb4:'.$uname.','.
        !          1255: 					 &Authen::Krb4::get_err_txt($Authen::Krb4::error));
        !          1256: 			    }
        !          1257: 			}
        !          1258: 		    }
        !          1259: 		} elsif ($howpwd eq 'krb5') {
        !          1260: 		    my $null=pack("C",0);
        !          1261: 		    unless ($upass=~/$null/) {
        !          1262: 			my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
        !          1263: 			my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
        !          1264: 			my $krbserver=&Authen::Krb5::parse_name($krbservice);
        !          1265: 			my $credentials=&Authen::Krb5::cc_default();
        !          1266: 			$credentials->initialize($krbclient);
        !          1267: 			my $krbreturn = 
        !          1268: 			    &Authen::Krb5::get_in_tkt_with_password(
        !          1269: 								    $krbclient,$krbserver,$upass,$credentials);
        !          1270: #				  unless ($krbreturn) {
        !          1271: #				      &logthis("Krb5 Error: ".
        !          1272: #					       &Authen::Krb5::error());
        !          1273: #				  }
        !          1274: 			$pwdcorrect = ($krbreturn == 1);
        !          1275: 		    } else { $pwdcorrect=0; }
        !          1276: 		} elsif ($howpwd eq 'localauth') {
        !          1277: 		    $pwdcorrect=&localauth::localauth($uname,$upass,
        !          1278: 						      $contentpwd);
        !          1279: 		}
        !          1280: 		if ($pwdcorrect) {
        !          1281: 		    print $client "authorized\n";
        !          1282: 		} else {
        !          1283: 		    print $client "non_authorized\n";
        !          1284: 		}  
        !          1285: 	    } else {
        !          1286: 		print $client "unknown_user\n";
        !          1287: 	    }
        !          1288: 	} else {
        !          1289: 	    Reply($client, "refused\n", $userinput);
        !          1290: 	    
        !          1291: 	}
        !          1292: # ---------------------------------------------------------------------- passwd
        !          1293:     } elsif ($userinput =~ /^passwd/) { # encoded and client
        !          1294: 	if (($wasenc==1) && isClient) {
        !          1295: 	    my 
        !          1296: 		($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
        !          1297: 	    chomp($npass);
        !          1298: 	    $upass=&unescape($upass);
        !          1299: 	    $npass=&unescape($npass);
        !          1300: 	    &Debug("Trying to change password for $uname");
        !          1301: 	    my $proname=propath($udom,$uname);
        !          1302: 	    my $passfilename="$proname/passwd";
        !          1303: 	    if (-e $passfilename) {
        !          1304: 		my $realpasswd;
        !          1305: 		{ my $pf = IO::File->new($passfilename);
        !          1306: 		  $realpasswd=<$pf>; }
        !          1307: 		chomp($realpasswd);
        !          1308: 		my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
        !          1309: 		if ($howpwd eq 'internal') {
        !          1310: 		    &Debug("internal auth");
        !          1311: 		    if (crypt($upass,$contentpwd) eq $contentpwd) {
        !          1312: 			my $salt=time;
        !          1313: 			$salt=substr($salt,6,2);
        !          1314: 			my $ncpass=crypt($npass,$salt);
        !          1315: 			{
        !          1316: 			    my $pf;
        !          1317: 			    if ($pf = IO::File->new(">$passfilename")) {
        !          1318: 				print $pf "internal:$ncpass\n";
        !          1319: 				&logthis("Result of password change for $uname: pwchange_success");
        !          1320: 				print $client "ok\n";
        !          1321: 			    } else {
        !          1322: 				&logthis("Unable to open $uname passwd to change password");
        !          1323: 				print $client "non_authorized\n";
        !          1324: 			    }
        !          1325: 			}             
        !          1326: 			
        !          1327: 		    } else {
        !          1328: 			print $client "non_authorized\n";
        !          1329: 		    }
        !          1330: 		} elsif ($howpwd eq 'unix') {
        !          1331: 		    # Unix means we have to access /etc/password
        !          1332: 		    # one way or another.
        !          1333: 		    # First: Make sure the current password is
        !          1334: 		    #        correct
        !          1335: 		    &Debug("auth is unix");
        !          1336: 		    $contentpwd=(getpwnam($uname))[1];
        !          1337: 		    my $pwdcorrect = "0";
        !          1338: 		    my $pwauth_path="/usr/local/sbin/pwauth";
        !          1339: 		    unless ($contentpwd eq 'x') {
        !          1340: 			$pwdcorrect=
        !          1341: 			    (crypt($upass,$contentpwd) eq $contentpwd);
        !          1342: 		    } elsif (-e $pwauth_path) {
        !          1343: 			open PWAUTH, "|$pwauth_path" or
        !          1344: 			    die "Cannot invoke authentication";
        !          1345: 			print PWAUTH "$uname\n$upass\n";
        !          1346: 			close PWAUTH;
        !          1347: 			&Debug("exited pwauth with $? ($uname,$upass) ");
        !          1348: 			$pwdcorrect=($? == 0);
        !          1349: 		    }
        !          1350: 		    if ($pwdcorrect) {
        !          1351: 			my $execdir=$perlvar{'lonDaemons'};
        !          1352: 			&Debug("Opening lcpasswd pipeline");
        !          1353: 			my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
        !          1354: 			print $pf "$uname\n$npass\n$npass\n";
        !          1355: 			close $pf;
        !          1356: 			my $err = $?;
        !          1357: 			my $result = ($err>0 ? 'pwchange_failure' 
        !          1358: 				      : 'ok');
        !          1359: 			&logthis("Result of password change for $uname: ".
        !          1360: 				 &lcpasswdstrerror($?));
        !          1361: 			print $client "$result\n";
        !          1362: 		    } else {
        !          1363: 			print $client "non_authorized\n";
        !          1364: 		    }
        !          1365: 		} else {
        !          1366: 		    print $client "auth_mode_error\n";
        !          1367: 		}  
        !          1368: 	    } else {
        !          1369: 		print $client "unknown_user\n";
        !          1370: 	    }
        !          1371: 	} else {
        !          1372: 	    Reply($client, "refused\n", $userinput);
        !          1373: 	    
        !          1374: 	}
        !          1375: # -------------------------------------------------------------------- makeuser
        !          1376:     } elsif ($userinput =~ /^makeuser/) { # encoded and client.
        !          1377: 	&Debug("Make user received");
        !          1378: 	my $oldumask=umask(0077);
        !          1379: 	if (($wasenc==1) && isClient) {
        !          1380: 	    my 
        !          1381: 		($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
        !          1382: 	    &Debug("cmd =".$cmd." $udom =".$udom.
        !          1383: 		   " uname=".$uname);
        !          1384: 	    chomp($npass);
        !          1385: 	    $npass=&unescape($npass);
        !          1386: 	    my $proname=propath($udom,$uname);
        !          1387: 	    my $passfilename="$proname/passwd";
        !          1388: 	    &Debug("Password file created will be:".
        !          1389: 		   $passfilename);
        !          1390: 	    if (-e $passfilename) {
        !          1391: 		print $client "already_exists\n";
        !          1392: 	    } elsif ($udom ne $currentdomainid) {
        !          1393: 		print $client "not_right_domain\n";
        !          1394: 	    } else {
        !          1395: 		my @fpparts=split(/\//,$proname);
        !          1396: 		my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
        !          1397: 		my $fperror='';
        !          1398: 		for (my $i=3;$i<=$#fpparts;$i++) {
        !          1399: 		    $fpnow.='/'.$fpparts[$i]; 
        !          1400: 		    unless (-e $fpnow) {
        !          1401: 			unless (mkdir($fpnow,0777)) {
        !          1402: 			    $fperror="error: ".($!+0)
        !          1403: 				." mkdir failed while attempting "
        !          1404: 				."makeuser";
        !          1405: 			}
        !          1406: 		    }
        !          1407: 		}
        !          1408: 		unless ($fperror) {
        !          1409: 		    my $result=&make_passwd_file($uname, $umode,$npass,
        !          1410: 						 $passfilename);
        !          1411: 		    print $client $result;
        !          1412: 		} else {
        !          1413: 		    print $client "$fperror\n";
        !          1414: 		}
        !          1415: 	    }
        !          1416: 	} else {
        !          1417: 	    Reply($client, "refused\n", $userinput);
        !          1418: 	    
        !          1419: 	}
        !          1420: 	umask($oldumask);
        !          1421: # -------------------------------------------------------------- changeuserauth
        !          1422:     } elsif ($userinput =~ /^changeuserauth/) { # encoded & client
        !          1423: 	&Debug("Changing authorization");
        !          1424: 	if (($wasenc==1) && isClient) {
        !          1425: 	    my 
        !          1426: 		($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
        !          1427: 	    chomp($npass);
        !          1428: 	    &Debug("cmd = ".$cmd." domain= ".$udom.
        !          1429: 		   "uname =".$uname." umode= ".$umode);
        !          1430: 	    $npass=&unescape($npass);
        !          1431: 	    my $proname=&propath($udom,$uname);
        !          1432: 	    my $passfilename="$proname/passwd";
        !          1433: 	    if ($udom ne $currentdomainid) {
        !          1434: 		print $client "not_right_domain\n";
        !          1435: 	    } else {
        !          1436: 		my $result=&make_passwd_file($uname, $umode,$npass,
        !          1437: 					     $passfilename);
        !          1438: 		print $client $result;
        !          1439: 	    }
        !          1440: 	} else {
        !          1441: 	    Reply($client, "refused\n", $userinput);
        !          1442: 	    
        !          1443: 	}
        !          1444: # ------------------------------------------------------------------------ home
        !          1445:     } elsif ($userinput =~ /^home/) { # client clear or encoded
        !          1446: 	if(isClient) {
        !          1447: 	    my ($cmd,$udom,$uname)=split(/:/,$userinput);
        !          1448: 	    chomp($uname);
        !          1449: 	    my $proname=propath($udom,$uname);
        !          1450: 	    if (-e $proname) {
        !          1451: 		print $client "found\n";
        !          1452: 	    } else {
        !          1453: 		print $client "not_found\n";
        !          1454: 	    }
        !          1455: 	} else {
        !          1456: 	    Reply($client, "refused\n", $userinput);
        !          1457: 	    
        !          1458: 	}
        !          1459: # ---------------------------------------------------------------------- update
        !          1460:     } elsif ($userinput =~ /^update/) { # client clear or encoded.
        !          1461: 	if(isClient) {
        !          1462: 	    my ($cmd,$fname)=split(/:/,$userinput);
        !          1463: 	    my $ownership=ishome($fname);
        !          1464: 	    if ($ownership eq 'not_owner') {
        !          1465: 		if (-e $fname) {
        !          1466: 		    my ($dev,$ino,$mode,$nlink,
        !          1467: 			$uid,$gid,$rdev,$size,
        !          1468: 			$atime,$mtime,$ctime,
        !          1469: 			$blksize,$blocks)=stat($fname);
        !          1470: 		    my $now=time;
        !          1471: 		    my $since=$now-$atime;
        !          1472: 		    if ($since>$perlvar{'lonExpire'}) {
        !          1473: 			my $reply=
        !          1474: 			    &reply("unsub:$fname","$clientname");
        !          1475: 				    unlink("$fname");
        !          1476: 		    } else {
        !          1477: 			my $transname="$fname.in.transfer";
        !          1478: 			my $remoteurl=
        !          1479: 			    &reply("sub:$fname","$clientname");
        !          1480: 			my $response;
        !          1481: 			{
        !          1482: 			    my $ua=new LWP::UserAgent;
        !          1483: 			    my $request=new HTTP::Request('GET',"$remoteurl");
        !          1484: 			    $response=$ua->request($request,$transname);
        !          1485: 			}
        !          1486: 			if ($response->is_error()) {
        !          1487: 			    unlink($transname);
        !          1488: 			    my $message=$response->status_line;
        !          1489: 			    &logthis(
        !          1490: 				     "LWP GET: $message for $fname ($remoteurl)");
        !          1491: 			} else {
        !          1492: 			    if ($remoteurl!~/\.meta$/) {
        !          1493: 				my $ua=new LWP::UserAgent;
        !          1494: 				my $mrequest=
        !          1495: 				    new HTTP::Request('GET',$remoteurl.'.meta');
        !          1496: 				my $mresponse=
        !          1497: 				    $ua->request($mrequest,$fname.'.meta');
        !          1498: 				if ($mresponse->is_error()) {
        !          1499: 				    unlink($fname.'.meta');
        !          1500: 				}
        !          1501: 			    }
        !          1502: 			    rename($transname,$fname);
        !          1503: 			}
        !          1504: 		    }
        !          1505: 		    print $client "ok\n";
        !          1506: 		} else {
        !          1507: 		    print $client "not_found\n";
        !          1508: 		}
        !          1509: 	    } else {
        !          1510: 		print $client "rejected\n";
        !          1511: 	    }
        !          1512: 	} else {
        !          1513: 	    Reply($client, "refused\n", $userinput);
        !          1514: 	    
        !          1515: 	}
        !          1516: # -------------------------------------- fetch a user file from a remote server
        !          1517:     } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
        !          1518: 	if(isClient) {
        !          1519: 	    my ($cmd,$fname)=split(/:/,$userinput);
        !          1520: 	    my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
        !          1521: 	    my $udir=propath($udom,$uname).'/userfiles';
        !          1522: 	    unless (-e $udir) { mkdir($udir,0770); }
        !          1523: 	    if (-e $udir) {
        !          1524: 		$ufile=~s/^[\.\~]+//;
        !          1525: 		my $path = $udir;
        !          1526: 		if ($ufile =~m|(.+)/([^/]+)$|) {
        !          1527: 		    my @parts=split('/',$1);
        !          1528: 		    foreach my $part (@parts) {
        !          1529: 			$path .= '/'.$part;
        !          1530: 			if ((-e $path)!=1) {
        !          1531: 			    mkdir($path,0770);
        !          1532: 			}
        !          1533: 		    }
        !          1534: 		}
        !          1535: 		my $destname=$udir.'/'.$ufile;
        !          1536: 		my $transname=$udir.'/'.$ufile.'.in.transit';
        !          1537: 		my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
        !          1538: 		my $response;
        !          1539: 		{
        !          1540: 		    my $ua=new LWP::UserAgent;
        !          1541: 		    my $request=new HTTP::Request('GET',"$remoteurl");
        !          1542: 		    $response=$ua->request($request,$transname);
        !          1543: 		}
        !          1544: 		if ($response->is_error()) {
        !          1545: 		    unlink($transname);
        !          1546: 		    my $message=$response->status_line;
        !          1547: 		    &logthis("LWP GET: $message for $fname ($remoteurl)");
        !          1548: 		    print $client "failed\n";
        !          1549: 		} else {
        !          1550: 		    if (!rename($transname,$destname)) {
        !          1551: 			&logthis("Unable to move $transname to $destname");
        !          1552: 			unlink($transname);
        !          1553: 			print $client "failed\n";
        !          1554: 		    } else {
        !          1555: 			print $client "ok\n";
        !          1556: 		    }
        !          1557: 		}
        !          1558: 	    } else {
        !          1559: 		print $client "not_home\n";
        !          1560: 	    }
        !          1561: 	} else {
        !          1562: 	    Reply($client, "refused\n", $userinput);
        !          1563: 	}
        !          1564: # --------------------------------------------------------- remove a user file 
        !          1565:     } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
        !          1566: 	if(isClient) {
        !          1567: 	    my ($cmd,$fname)=split(/:/,$userinput);
        !          1568: 	    my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
        !          1569: 	    &logthis("$udom - $uname - $ufile");
        !          1570: 	    if ($ufile =~m|/\.\./|) {
        !          1571: 		# any files paths with /../ in them refuse 
        !          1572: 		# to deal with
        !          1573: 		print $client "refused\n";
        !          1574: 	    } else {
        !          1575: 		my $udir=propath($udom,$uname);
        !          1576: 		if (-e $udir) {
        !          1577: 		    my $file=$udir.'/userfiles/'.$ufile;
        !          1578: 		    if (-e $file) {
        !          1579: 			unlink($file);
        !          1580: 			if (-e $file) {
        !          1581: 			    print $client "failed\n";
        !          1582: 			} else {
        !          1583: 			    print $client "ok\n";
        !          1584: 			}
        !          1585: 		    } else {
        !          1586: 			print $client "not_found\n";
        !          1587: 		    }
        !          1588: 		} else {
        !          1589: 		    print $client "not_home\n";
        !          1590: 		}
        !          1591: 	    }
        !          1592: 	} else {
        !          1593: 	    Reply($client, "refused\n", $userinput);
        !          1594: 	}
        !          1595: # ------------------------------------------ authenticate access to a user file
        !          1596:     } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
        !          1597: 	if(isClient) {
        !          1598: 	    my ($cmd,$fname,$session)=split(/:/,$userinput);
        !          1599: 	    chomp($session);
        !          1600: 	    my $reply='non_auth';
        !          1601: 	    if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
        !          1602: 		     $session.'.id')) {
        !          1603: 		while (my $line=<ENVIN>) {
        !          1604: 		    if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
        !          1605: 			    }
        !          1606: 		close(ENVIN);
        !          1607: 		print $client $reply."\n";
        !          1608: 	    } else {
        !          1609: 		print $client "invalid_token\n";
        !          1610: 	    }
        !          1611: 	} else {
        !          1612: 	    Reply($client, "refused\n", $userinput);
        !          1613: 	    
        !          1614: 	}
        !          1615: # ----------------------------------------------------------------- unsubscribe
        !          1616:     } elsif ($userinput =~ /^unsub/) {
        !          1617: 	if(isClient) {
        !          1618: 	    my ($cmd,$fname)=split(/:/,$userinput);
        !          1619: 	    if (-e $fname) {
        !          1620: 		print $client &unsub($fname,$clientip);
        !          1621: 	    } else {
        !          1622: 		print $client "not_found\n";
        !          1623: 	    }
        !          1624: 	} else {
        !          1625: 	    Reply($client, "refused\n", $userinput);
        !          1626: 	    
        !          1627: 	}
        !          1628: # ------------------------------------------------------------------- subscribe
        !          1629:     } elsif ($userinput =~ /^sub/) {
        !          1630: 	if(isClient) {
        !          1631: 	    print $client &subscribe($userinput,$clientip);
        !          1632: 	} else {
        !          1633: 	    Reply($client, "refused\n", $userinput);
        !          1634: 	    
        !          1635: 	}
        !          1636: # ------------------------------------------------------------- current version
        !          1637:     } elsif ($userinput =~ /^currentversion/) {
        !          1638: 	if(isClient) {
        !          1639: 	    my ($cmd,$fname)=split(/:/,$userinput);
        !          1640: 	    print $client &currentversion($fname)."\n";
        !          1641: 	} else {
        !          1642: 	    Reply($client, "refused\n", $userinput);
        !          1643: 	    
        !          1644: 	}
        !          1645: # ------------------------------------------------------------------------- log
        !          1646:     } elsif ($userinput =~ /^log/) {
        !          1647: 	if(isClient) {
        !          1648: 	    my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
        !          1649: 	    chomp($what);
        !          1650: 	    my $proname=propath($udom,$uname);
        !          1651: 	    my $now=time;
        !          1652: 	    {
        !          1653: 		my $hfh;
        !          1654: 		if ($hfh=IO::File->new(">>$proname/activity.log")) { 
        !          1655: 		    print $hfh "$now:$clientname:$what\n";
        !          1656: 		    print $client "ok\n"; 
        !          1657: 		} else {
        !          1658: 		    print $client "error: ".($!+0)
        !          1659: 			." IO::File->new Failed "
        !          1660: 			."while attempting log\n";
        !          1661: 		}
        !          1662: 	    }
        !          1663: 	} else {
        !          1664: 	    Reply($client, "refused\n", $userinput);
        !          1665: 	    
        !          1666: 	}
        !          1667: # ------------------------------------------------------------------------- put
        !          1668:     } elsif ($userinput =~ /^put/) {
        !          1669: 	if(isClient) {
        !          1670: 	    my ($cmd,$udom,$uname,$namespace,$what)
        !          1671: 		=split(/:/,$userinput,5);
        !          1672: 	    $namespace=~s/\//\_/g;
        !          1673: 	    $namespace=~s/\W//g;
        !          1674: 	    if ($namespace ne 'roles') {
        !          1675: 		chomp($what);
        !          1676: 		my $proname=propath($udom,$uname);
        !          1677: 		my $now=time;
        !          1678: 		my @pairs=split(/\&/,$what);
        !          1679: 		my %hash;
        !          1680: 		if (tie(%hash,'GDBM_File',
        !          1681: 			"$proname/$namespace.db",
        !          1682: 			&GDBM_WRCREAT(),0640)) {
        !          1683: 		    unless ($namespace=~/^nohist\_/) {
        !          1684: 			my $hfh;
        !          1685: 			if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
        !          1686: 		    }
        !          1687: 		    
        !          1688: 		    foreach my $pair (@pairs) {
        !          1689: 			my ($key,$value)=split(/=/,$pair);
        !          1690: 			$hash{$key}=$value;
        !          1691: 		    }
        !          1692: 		    if (untie(%hash)) {
        !          1693: 			print $client "ok\n";
        !          1694: 		    } else {
        !          1695: 			print $client "error: ".($!+0)
        !          1696: 			    ." untie(GDBM) failed ".
        !          1697: 			    "while attempting put\n";
        !          1698: 		    }
        !          1699: 		} else {
        !          1700: 		    print $client "error: ".($!)
        !          1701: 			." tie(GDBM) Failed ".
        !          1702: 			"while attempting put\n";
        !          1703: 		}
        !          1704: 	    } else {
        !          1705: 		print $client "refused\n";
        !          1706: 	    }
        !          1707: 	} else {
        !          1708: 	    Reply($client, "refused\n", $userinput);
        !          1709: 	    
        !          1710: 	}
        !          1711: # ------------------------------------------------------------------- inc
        !          1712:     } elsif ($userinput =~ /^inc:/) {
        !          1713: 	if(isClient) {
        !          1714: 	    my ($cmd,$udom,$uname,$namespace,$what)
        !          1715: 		=split(/:/,$userinput);
        !          1716: 	    $namespace=~s/\//\_/g;
        !          1717: 	    $namespace=~s/\W//g;
        !          1718: 	    if ($namespace ne 'roles') {
        !          1719: 		chomp($what);
        !          1720: 		my $proname=propath($udom,$uname);
        !          1721: 		my $now=time;
        !          1722: 		my @pairs=split(/\&/,$what);
        !          1723: 		my %hash;
        !          1724: 		if (tie(%hash,'GDBM_File',
        !          1725: 			"$proname/$namespace.db",
        !          1726: 			&GDBM_WRCREAT(),0640)) {
        !          1727: 		    unless ($namespace=~/^nohist\_/) {
        !          1728: 			my $hfh;
        !          1729: 			if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
        !          1730: 		    }
        !          1731: 		    foreach my $pair (@pairs) {
        !          1732: 			my ($key,$value)=split(/=/,$pair);
        !          1733: 			# We could check that we have a number...
        !          1734: 			if (! defined($value) || $value eq '') {
        !          1735: 			    $value = 1;
        !          1736: 			}
        !          1737: 			$hash{$key}+=$value;
        !          1738: 		    }
        !          1739: 		    if (untie(%hash)) {
        !          1740: 			print $client "ok\n";
        !          1741: 		    } else {
        !          1742: 			print $client "error: ".($!+0)
        !          1743: 			    ." untie(GDBM) failed ".
        !          1744: 			    "while attempting inc\n";
        !          1745: 		    }
        !          1746: 		} else {
        !          1747: 		    print $client "error: ".($!)
        !          1748: 			." tie(GDBM) Failed ".
        !          1749: 			"while attempting inc\n";
        !          1750: 		}
        !          1751: 	    } else {
        !          1752: 		print $client "refused\n";
        !          1753: 	    }
        !          1754: 	} else {
        !          1755: 	    Reply($client, "refused\n", $userinput);
        !          1756: 	    
        !          1757: 	}
        !          1758: # -------------------------------------------------------------------- rolesput
        !          1759:     } elsif ($userinput =~ /^rolesput/) {
        !          1760: 	if(isClient) {
        !          1761: 	    &Debug("rolesput");
        !          1762: 	    if ($wasenc==1) {
        !          1763: 		my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
        !          1764: 		    =split(/:/,$userinput);
        !          1765: 		&Debug("cmd = ".$cmd." exedom= ".$exedom.
        !          1766: 		       "user = ".$exeuser." udom=".$udom.
        !          1767: 		       "what = ".$what);
        !          1768: 		my $namespace='roles';
        !          1769: 		chomp($what);
        !          1770: 		my $proname=propath($udom,$uname);
        !          1771: 		my $now=time;
        !          1772: 		my @pairs=split(/\&/,$what);
        !          1773: 		my %hash;
        !          1774: 		if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
        !          1775: 		    {
        !          1776: 			my $hfh;
        !          1777: 			if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
        !          1778: 			    print $hfh "P:$now:$exedom:$exeuser:$what\n";
        !          1779: 			}
        !          1780: 		    }
        !          1781: 		    
        !          1782: 		    foreach my $pair (@pairs) {
        !          1783: 			my ($key,$value)=split(/=/,$pair);
        !          1784: 			&ManagePermissions($key, $udom, $uname,
        !          1785: 					   &GetAuthType( $udom, 
        !          1786: 							 $uname));
        !          1787: 			$hash{$key}=$value;
        !          1788: 		    }
        !          1789: 		    if (untie(%hash)) {
        !          1790: 			print $client "ok\n";
        !          1791: 		    } else {
        !          1792: 			print $client "error: ".($!+0)
        !          1793: 			    ." untie(GDBM) Failed ".
        !          1794: 			    "while attempting rolesput\n";
        !          1795: 		    }
        !          1796: 		} else {
        !          1797: 		    print $client "error: ".($!+0)
        !          1798: 			." tie(GDBM) Failed ".
        !          1799: 			"while attempting rolesput\n";
        !          1800: 			    }
        !          1801: 	    } else {
        !          1802: 		print $client "refused\n";
        !          1803: 	    }
        !          1804: 	} else {
        !          1805: 	    Reply($client, "refused\n", $userinput);
        !          1806: 	    
        !          1807: 	}
        !          1808: # -------------------------------------------------------------------- rolesdel
        !          1809:     } elsif ($userinput =~ /^rolesdel/) {
        !          1810: 	if(isClient) {
        !          1811: 	    &Debug("rolesdel");
        !          1812: 	    if ($wasenc==1) {
        !          1813: 		my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
        !          1814: 		    =split(/:/,$userinput);
        !          1815: 		&Debug("cmd = ".$cmd." exedom= ".$exedom.
        !          1816: 		       "user = ".$exeuser." udom=".$udom.
        !          1817: 		       "what = ".$what);
        !          1818: 		my $namespace='roles';
        !          1819: 		chomp($what);
        !          1820: 		my $proname=propath($udom,$uname);
        !          1821: 		my $now=time;
        !          1822: 		my @rolekeys=split(/\&/,$what);
        !          1823: 		my %hash;
        !          1824: 		if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
        !          1825: 		    {
        !          1826: 			my $hfh;
        !          1827: 			if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
        !          1828: 			    print $hfh "D:$now:$exedom:$exeuser:$what\n";
        !          1829: 			}
        !          1830: 		    }
        !          1831: 		    foreach my $key (@rolekeys) {
        !          1832: 			delete $hash{$key};
        !          1833: 		    }
        !          1834: 		    if (untie(%hash)) {
        !          1835: 			print $client "ok\n";
        !          1836: 		    } else {
        !          1837: 			print $client "error: ".($!+0)
        !          1838: 			    ." untie(GDBM) Failed ".
        !          1839: 			    "while attempting rolesdel\n";
        !          1840: 		    }
        !          1841: 		} else {
        !          1842: 		    print $client "error: ".($!+0)
        !          1843: 			." tie(GDBM) Failed ".
        !          1844: 			"while attempting rolesdel\n";
        !          1845: 		}
        !          1846: 	    } else {
        !          1847: 		print $client "refused\n";
        !          1848: 	    }
        !          1849: 	} else {
        !          1850: 	    Reply($client, "refused\n", $userinput);
        !          1851: 	    
        !          1852: 	}
        !          1853: # ------------------------------------------------------------------------- get
        !          1854:     } elsif ($userinput =~ /^get/) {
        !          1855: 	if(isClient) {
        !          1856: 	    my ($cmd,$udom,$uname,$namespace,$what)
        !          1857: 		=split(/:/,$userinput);
        !          1858: 	    $namespace=~s/\//\_/g;
        !          1859: 	    $namespace=~s/\W//g;
        !          1860: 	    chomp($what);
        !          1861: 	    my @queries=split(/\&/,$what);
        !          1862: 	    my $proname=propath($udom,$uname);
        !          1863: 	    my $qresult='';
        !          1864: 	    my %hash;
        !          1865: 	    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
        !          1866: 		for (my $i=0;$i<=$#queries;$i++) {
        !          1867: 		    $qresult.="$hash{$queries[$i]}&";
        !          1868: 		}
        !          1869: 		if (untie(%hash)) {
        !          1870: 		    $qresult=~s/\&$//;
        !          1871: 		    print $client "$qresult\n";
        !          1872: 		} else {
        !          1873: 		    print $client "error: ".($!+0)
        !          1874: 			." untie(GDBM) Failed ".
        !          1875: 			"while attempting get\n";
        !          1876: 		}
        !          1877: 	    } else {
        !          1878: 		if ($!+0 == 2) {
        !          1879: 		    print $client "error:No such file or ".
        !          1880: 			"GDBM reported bad block error\n";
        !          1881: 		} else {
        !          1882: 		    print $client "error: ".($!+0)
        !          1883: 			." tie(GDBM) Failed ".
        !          1884: 			"while attempting get\n";
        !          1885: 		}
        !          1886: 	    }
        !          1887: 	} else {
        !          1888: 	    Reply($client, "refused\n", $userinput);
        !          1889: 	    
        !          1890: 	}
        !          1891: # ------------------------------------------------------------------------ eget
        !          1892:     } elsif ($userinput =~ /^eget/) {
        !          1893: 	if (isClient) {
        !          1894: 	    my ($cmd,$udom,$uname,$namespace,$what)
        !          1895: 		=split(/:/,$userinput);
        !          1896: 	    $namespace=~s/\//\_/g;
        !          1897: 	    $namespace=~s/\W//g;
        !          1898: 	    chomp($what);
        !          1899: 	    my @queries=split(/\&/,$what);
        !          1900: 	    my $proname=propath($udom,$uname);
        !          1901: 	    my $qresult='';
        !          1902: 	    my %hash;
        !          1903: 	    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
        !          1904: 		for (my $i=0;$i<=$#queries;$i++) {
        !          1905: 		    $qresult.="$hash{$queries[$i]}&";
        !          1906: 		}
        !          1907: 		if (untie(%hash)) {
        !          1908: 		    $qresult=~s/\&$//;
        !          1909: 		    if ($cipher) {
        !          1910: 			my $cmdlength=length($qresult);
        !          1911: 			$qresult.="         ";
        !          1912: 			my $encqresult='';
        !          1913: 			for 
        !          1914: 			    (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
        !          1915: 				$encqresult.=
        !          1916: 				    unpack("H16",
        !          1917: 					   $cipher->encrypt(substr($qresult,$encidx,8)));
        !          1918: 			    }
        !          1919: 			print $client "enc:$cmdlength:$encqresult\n";
        !          1920: 		    } else {
        !          1921: 			print $client "error:no_key\n";
        !          1922: 		    }
        !          1923: 		} else {
        !          1924: 		    print $client "error: ".($!+0)
        !          1925: 			." untie(GDBM) Failed ".
        !          1926: 			"while attempting eget\n";
        !          1927: 		}
        !          1928: 	    } else {
        !          1929: 		print $client "error: ".($!+0)
        !          1930: 		    ." tie(GDBM) Failed ".
        !          1931: 		    "while attempting eget\n";
        !          1932: 	    }
        !          1933: 	} else {
        !          1934: 	    Reply($client, "refused\n", $userinput);
        !          1935: 	    
        !          1936: 	}
        !          1937: # ------------------------------------------------------------------------- del
        !          1938:     } elsif ($userinput =~ /^del/) {
        !          1939: 	if(isClient) {
        !          1940: 	    my ($cmd,$udom,$uname,$namespace,$what)
        !          1941: 		=split(/:/,$userinput);
        !          1942: 	    $namespace=~s/\//\_/g;
        !          1943: 	    $namespace=~s/\W//g;
        !          1944: 	    chomp($what);
        !          1945: 	    my $proname=propath($udom,$uname);
        !          1946: 	    my $now=time;
        !          1947: 	    my @keys=split(/\&/,$what);
        !          1948: 	    my %hash;
        !          1949: 	    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
        !          1950: 		unless ($namespace=~/^nohist\_/) {
        !          1951: 		    my $hfh;
        !          1952: 		    if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; }
        !          1953: 		}
        !          1954: 		foreach my $key (@keys) {
        !          1955: 		    delete($hash{$key});
        !          1956: 		}
        !          1957: 		if (untie(%hash)) {
        !          1958: 		    print $client "ok\n";
        !          1959: 		} else {
        !          1960: 		    print $client "error: ".($!+0)
        !          1961: 			." untie(GDBM) Failed ".
        !          1962: 			"while attempting del\n";
        !          1963: 		}
        !          1964: 	    } else {
        !          1965: 		print $client "error: ".($!+0)
        !          1966: 		    ." tie(GDBM) Failed ".
        !          1967: 		    "while attempting del\n";
        !          1968: 	    }
        !          1969: 	} else {
        !          1970: 	    Reply($client, "refused\n", $userinput);
        !          1971: 	    
        !          1972: 	}
        !          1973: # ------------------------------------------------------------------------ keys
        !          1974:     } elsif ($userinput =~ /^keys/) {
        !          1975: 	if(isClient) {
        !          1976: 	    my ($cmd,$udom,$uname,$namespace)
        !          1977: 		=split(/:/,$userinput);
        !          1978: 	    $namespace=~s/\//\_/g;
        !          1979: 	    $namespace=~s/\W//g;
        !          1980: 	    my $proname=propath($udom,$uname);
        !          1981: 	    my $qresult='';
        !          1982: 	    my %hash;
        !          1983: 	    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
        !          1984: 		foreach my $key (keys %hash) {
        !          1985: 		    $qresult.="$key&";
        !          1986: 		}
        !          1987: 		if (untie(%hash)) {
        !          1988: 		    $qresult=~s/\&$//;
        !          1989: 		    print $client "$qresult\n";
        !          1990: 		} else {
        !          1991: 		    print $client "error: ".($!+0)
        !          1992: 			." untie(GDBM) Failed ".
        !          1993: 			"while attempting keys\n";
        !          1994: 		}
        !          1995: 	    } else {
        !          1996: 		print $client "error: ".($!+0)
        !          1997: 		    ." tie(GDBM) Failed ".
        !          1998: 		    "while attempting keys\n";
        !          1999: 	    }
        !          2000: 	} else {
        !          2001: 	    Reply($client, "refused\n", $userinput);
        !          2002: 	    
        !          2003: 	}
        !          2004: # ----------------------------------------------------------------- dumpcurrent
        !          2005:     } elsif ($userinput =~ /^currentdump/) {
        !          2006: 	if (isClient) {
        !          2007: 	    my ($cmd,$udom,$uname,$namespace)
        !          2008: 		=split(/:/,$userinput);
        !          2009: 	    $namespace=~s/\//\_/g;
        !          2010: 	    $namespace=~s/\W//g;
        !          2011: 	    my $qresult='';
        !          2012: 	    my $proname=propath($udom,$uname);
        !          2013: 	    my %hash;
        !          2014: 	    if (tie(%hash,'GDBM_File',
        !          2015: 		    "$proname/$namespace.db",
        !          2016: 		    &GDBM_READER(),0640)) {
        !          2017: 			    # Structure of %data:
        !          2018: 		# $data{$symb}->{$parameter}=$value;
        !          2019: 		# $data{$symb}->{'v.'.$parameter}=$version;
        !          2020: 		# since $parameter will be unescaped, we do not
        !          2021: 		# have to worry about silly parameter names...
        !          2022: 		my %data = ();
        !          2023: 		while (my ($key,$value) = each(%hash)) {
        !          2024: 		    my ($v,$symb,$param) = split(/:/,$key);
        !          2025: 		    next if ($v eq 'version' || $symb eq 'keys');
        !          2026: 		    next if (exists($data{$symb}) && 
        !          2027: 			     exists($data{$symb}->{$param}) &&
        !          2028: 			     $data{$symb}->{'v.'.$param} > $v);
        !          2029: 		    $data{$symb}->{$param}=$value;
        !          2030: 		    $data{$symb}->{'v.'.$param}=$v;
        !          2031: 		}
        !          2032: 		if (untie(%hash)) {
        !          2033: 		    while (my ($symb,$param_hash) = each(%data)) {
        !          2034: 			while(my ($param,$value) = each (%$param_hash)){
        !          2035: 			    next if ($param =~ /^v\./);
        !          2036: 			    $qresult.=$symb.':'.$param.'='.$value.'&';
        !          2037: 			}
        !          2038: 		    }
        !          2039: 		    chop($qresult);
        !          2040: 		    print $client "$qresult\n";
        !          2041: 		} else {
        !          2042: 		    print $client "error: ".($!+0)
        !          2043: 			." untie(GDBM) Failed ".
        !          2044: 			"while attempting currentdump\n";
        !          2045: 		}
        !          2046: 	    } else {
        !          2047: 		print $client "error: ".($!+0)
        !          2048: 		    ." tie(GDBM) Failed ".
        !          2049: 		    "while attempting currentdump\n";
        !          2050: 	    }
        !          2051: 	} else {
        !          2052: 	    Reply($client, "refused\n", $userinput);
        !          2053: 	}
        !          2054: # ------------------------------------------------------------------------ dump
        !          2055:     } elsif ($userinput =~ /^dump/) {
        !          2056: 	if(isClient) {
        !          2057: 	    my ($cmd,$udom,$uname,$namespace,$regexp)
        !          2058: 		=split(/:/,$userinput);
        !          2059: 	    $namespace=~s/\//\_/g;
        !          2060: 	    $namespace=~s/\W//g;
        !          2061: 	    if (defined($regexp)) {
        !          2062: 		$regexp=&unescape($regexp);
        !          2063: 	    } else {
        !          2064: 		$regexp='.';
        !          2065: 	    }
        !          2066: 	    my $qresult='';
        !          2067: 	    my $proname=propath($udom,$uname);
        !          2068: 	    my %hash;
        !          2069: 	    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
        !          2070: 		while (my ($key,$value) = each(%hash)) {
        !          2071: 		    if ($regexp eq '.') {
        !          2072: 			$qresult.=$key.'='.$value.'&';
        !          2073: 		    } else {
        !          2074: 			my $unescapeKey = &unescape($key);
        !          2075: 			if (eval('$unescapeKey=~/$regexp/')) {
        !          2076: 			    $qresult.="$key=$value&";
        !          2077: 			}
        !          2078: 		    }
        !          2079: 		}
        !          2080: 		if (untie(%hash)) {
        !          2081: 		    chop($qresult);
        !          2082: 		    print $client "$qresult\n";
        !          2083: 		} else {
        !          2084: 		    print $client "error: ".($!+0)
        !          2085: 			." untie(GDBM) Failed ".
        !          2086: 			"while attempting dump\n";
        !          2087: 		}
        !          2088: 	    } else {
        !          2089: 		print $client "error: ".($!+0)
        !          2090: 		    ." tie(GDBM) Failed ".
        !          2091: 		    "while attempting dump\n";
        !          2092: 	    }
        !          2093: 	} else {
        !          2094: 	    Reply($client, "refused\n", $userinput);
        !          2095: 	    
        !          2096: 	}
        !          2097: # ----------------------------------------------------------------------- store
        !          2098:     } elsif ($userinput =~ /^store/) {
        !          2099: 	if(isClient) {
        !          2100: 	    my ($cmd,$udom,$uname,$namespace,$rid,$what)
        !          2101: 		=split(/:/,$userinput);
        !          2102: 	    $namespace=~s/\//\_/g;
        !          2103: 	    $namespace=~s/\W//g;
        !          2104: 	    if ($namespace ne 'roles') {
        !          2105: 		chomp($what);
        !          2106: 		my $proname=propath($udom,$uname);
        !          2107: 		my $now=time;
        !          2108: 		my @pairs=split(/\&/,$what);
        !          2109: 		my %hash;
        !          2110: 		if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
        !          2111: 		    unless ($namespace=~/^nohist\_/) {
        !          2112: 			my $hfh;
        !          2113: 			if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
        !          2114: 			    print $hfh "P:$now:$rid:$what\n";
        !          2115: 			}
        !          2116: 		    }
        !          2117: 		    my @previouskeys=split(/&/,$hash{"keys:$rid"});
        !          2118: 		    my $key;
        !          2119: 		    $hash{"version:$rid"}++;
        !          2120: 		    my $version=$hash{"version:$rid"};
        !          2121: 		    my $allkeys=''; 
        !          2122: 		    foreach my $pair (@pairs) {
        !          2123: 			my ($key,$value)=split(/=/,$pair);
        !          2124: 			$allkeys.=$key.':';
        !          2125: 			$hash{"$version:$rid:$key"}=$value;
        !          2126: 		    }
        !          2127: 		    $hash{"$version:$rid:timestamp"}=$now;
        !          2128: 		    $allkeys.='timestamp';
        !          2129: 		    $hash{"$version:keys:$rid"}=$allkeys;
        !          2130: 		    if (untie(%hash)) {
        !          2131: 			print $client "ok\n";
        !          2132: 		    } else {
        !          2133: 			print $client "error: ".($!+0)
        !          2134: 			    ." untie(GDBM) Failed ".
        !          2135: 			    "while attempting store\n";
        !          2136: 				}
        !          2137: 		} else {
        !          2138: 		    print $client "error: ".($!+0)
        !          2139: 			." tie(GDBM) Failed ".
        !          2140: 			"while attempting store\n";
        !          2141: 		}
        !          2142: 	    } else {
        !          2143: 		print $client "refused\n";
        !          2144: 	    }
        !          2145: 	} else {
        !          2146: 	    Reply($client, "refused\n", $userinput);
        !          2147: 	    
        !          2148: 	}
        !          2149: # --------------------------------------------------------------------- restore
        !          2150:     } elsif ($userinput =~ /^restore/) {
        !          2151: 	if(isClient) {
        !          2152: 	    my ($cmd,$udom,$uname,$namespace,$rid)
        !          2153: 		=split(/:/,$userinput);
        !          2154: 	    $namespace=~s/\//\_/g;
        !          2155: 	    $namespace=~s/\W//g;
        !          2156: 	    chomp($rid);
        !          2157: 	    my $proname=propath($udom,$uname);
        !          2158: 	    my $qresult='';
        !          2159: 	    my %hash;
        !          2160: 	    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
        !          2161: 		my $version=$hash{"version:$rid"};
        !          2162: 		$qresult.="version=$version&";
        !          2163: 		my $scope;
        !          2164: 		for ($scope=1;$scope<=$version;$scope++) {
        !          2165: 		    my $vkeys=$hash{"$scope:keys:$rid"};
        !          2166: 		    my @keys=split(/:/,$vkeys);
        !          2167: 		    my $key;
        !          2168: 		    $qresult.="$scope:keys=$vkeys&";
        !          2169: 		    foreach $key (@keys) {
        !          2170: 			$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
        !          2171: 		    }                                  
        !          2172: 		}
        !          2173: 		if (untie(%hash)) {
        !          2174: 		    $qresult=~s/\&$//;
        !          2175: 		    print $client "$qresult\n";
        !          2176: 		} else {
        !          2177: 		    print $client "error: ".($!+0)
        !          2178: 			." untie(GDBM) Failed ".
        !          2179: 			"while attempting restore\n";
        !          2180: 		}
        !          2181: 	    } else {
        !          2182: 		print $client "error: ".($!+0)
        !          2183: 		    ." tie(GDBM) Failed ".
        !          2184: 		    "while attempting restore\n";
        !          2185: 	    }
        !          2186: 	} else  {
        !          2187: 	    Reply($client, "refused\n", $userinput);
        !          2188: 	    
        !          2189: 	}
        !          2190: # -------------------------------------------------------------------- chatsend
        !          2191:     } elsif ($userinput =~ /^chatsend/) {
        !          2192: 	if(isClient) {
        !          2193: 	    my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
        !          2194: 	    &chatadd($cdom,$cnum,$newpost);
        !          2195: 	    print $client "ok\n";
        !          2196: 	} else {
        !          2197: 	    Reply($client, "refused\n", $userinput);
        !          2198: 	    
        !          2199: 	}
        !          2200: # -------------------------------------------------------------------- chatretr
        !          2201:     } elsif ($userinput =~ /^chatretr/) {
        !          2202: 	if(isClient) {
        !          2203: 	    my 
        !          2204: 		($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
        !          2205: 	    my $reply='';
        !          2206: 	    foreach (&getchat($cdom,$cnum,$udom,$uname)) {
        !          2207: 		$reply.=&escape($_).':';
        !          2208: 	    }
        !          2209: 	    $reply=~s/\:$//;
        !          2210: 	    print $client $reply."\n";
        !          2211: 	} else {
        !          2212: 	    Reply($client, "refused\n", $userinput);
        !          2213: 	    
        !          2214: 	}
        !          2215: # ------------------------------------------------------------------- querysend
        !          2216:     } elsif ($userinput =~ /^querysend/) {
        !          2217: 	if (isClient) {
        !          2218: 	    my ($cmd,$query,
        !          2219: 		$arg1,$arg2,$arg3)=split(/\:/,$userinput);
        !          2220: 	    $query=~s/\n*$//g;
        !          2221: 	    print $client "".
        !          2222: 		sqlreply("$clientname\&$query".
        !          2223: 			 "\&$arg1"."\&$arg2"."\&$arg3")."\n";
        !          2224: 	} else {
        !          2225: 	    Reply($client, "refused\n", $userinput);
        !          2226: 	    
        !          2227: 	}
        !          2228: # ------------------------------------------------------------------ queryreply
        !          2229:     } elsif ($userinput =~ /^queryreply/) {
        !          2230: 	if(isClient) {
        !          2231: 	    my ($cmd,$id,$reply)=split(/:/,$userinput); 
        !          2232: 	    my $store;
        !          2233: 	    my $execdir=$perlvar{'lonDaemons'};
        !          2234: 	    if ($store=IO::File->new(">$execdir/tmp/$id")) {
        !          2235: 		$reply=~s/\&/\n/g;
        !          2236: 		print $store $reply;
        !          2237: 		close $store;
        !          2238: 		my $store2=IO::File->new(">$execdir/tmp/$id.end");
        !          2239: 		print $store2 "done\n";
        !          2240: 		close $store2;
        !          2241: 		print $client "ok\n";
        !          2242: 	    }
        !          2243: 	    else {
        !          2244: 		print $client "error: ".($!+0)
        !          2245: 		    ." IO::File->new Failed ".
        !          2246: 		    "while attempting queryreply\n";
        !          2247: 	    }
        !          2248: 	} else {
        !          2249: 	    Reply($client, "refused\n", $userinput);
        !          2250: 	    
        !          2251: 	}
        !          2252: # ----------------------------------------------------------------- courseidput
        !          2253:     } elsif ($userinput =~ /^courseidput/) {
        !          2254: 	if(isClient) {
        !          2255: 	    my ($cmd,$udom,$what)=split(/:/,$userinput);
        !          2256: 	    chomp($what);
        !          2257: 			$udom=~s/\W//g;
        !          2258: 	    my $proname=
        !          2259: 		"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
        !          2260: 	    my $now=time;
        !          2261: 	    my @pairs=split(/\&/,$what);
        !          2262: 	    my %hash;
        !          2263: 	    if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
        !          2264: 		foreach my $pair (@pairs) {
        !          2265: 		    my ($key,$descr,$inst_code)=split(/=/,$pair);
        !          2266: 		    $hash{$key}=$descr.':'.$inst_code.':'.$now;
        !          2267: 		}
        !          2268: 		if (untie(%hash)) {
        !          2269: 		    print $client "ok\n";
        !          2270: 		} else {
        !          2271: 		    print $client "error: ".($!+0)
        !          2272: 			." untie(GDBM) Failed ".
        !          2273: 			"while attempting courseidput\n";
        !          2274: 		}
        !          2275: 	    } else {
        !          2276: 		print $client "error: ".($!+0)
        !          2277: 		    ." tie(GDBM) Failed ".
        !          2278: 		    "while attempting courseidput\n";
        !          2279: 	    }
        !          2280: 	} else {
        !          2281: 	    Reply($client, "refused\n", $userinput);
        !          2282: 	    
        !          2283: 	}
        !          2284: # ---------------------------------------------------------------- courseiddump
        !          2285:     } elsif ($userinput =~ /^courseiddump/) {
        !          2286: 	if(isClient) {
        !          2287: 	    my ($cmd,$udom,$since,$description)
        !          2288: 		=split(/:/,$userinput);
        !          2289: 	    if (defined($description)) {
        !          2290: 		$description=&unescape($description);
        !          2291: 	    } else {
        !          2292: 		$description='.';
        !          2293: 	    }
        !          2294: 	    unless (defined($since)) { $since=0; }
        !          2295: 	    my $qresult='';
        !          2296: 	    my $proname=
        !          2297: 		"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
        !          2298: 	    my %hash;
        !          2299: 	    if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
        !          2300: 		while (my ($key,$value) = each(%hash)) {
        !          2301: 		    my ($descr,$lasttime,$inst_code);
        !          2302: 		    if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {
        !          2303: 			($descr,$inst_code,$lasttime)=($1,$2,$3);
        !          2304: 		    } else {
        !          2305: 			($descr,$lasttime) = split(/\:/,$value);
        !          2306: 		    }
        !          2307: 		    if ($lasttime<$since) { next; }
        !          2308: 		    if ($description eq '.') {
        !          2309: 			$qresult.=$key.'='.$descr.':'.$inst_code.'&';
        !          2310: 		    } else {
        !          2311: 			my $unescapeVal = &unescape($descr);
        !          2312: 			if (eval('$unescapeVal=~/\Q$description\E/i')) {
        !          2313: 			    $qresult.=$key.'='.$descr.':'.$inst_code.'&';
        !          2314: 			}
        !          2315: 		    }
        !          2316: 		}
        !          2317: 		if (untie(%hash)) {
        !          2318: 		    chop($qresult);
        !          2319: 		    print $client "$qresult\n";
        !          2320: 		} else {
        !          2321: 		    print $client "error: ".($!+0)
        !          2322: 			." untie(GDBM) Failed ".
        !          2323: 			"while attempting courseiddump\n";
        !          2324: 		}
        !          2325: 	    } else {
        !          2326: 		print $client "error: ".($!+0)
        !          2327: 		    ." tie(GDBM) Failed ".
        !          2328: 		    "while attempting courseiddump\n";
        !          2329: 	    }
        !          2330: 	} else {
        !          2331: 	    Reply($client, "refused\n", $userinput);
        !          2332: 	    
        !          2333: 	}
        !          2334: # ----------------------------------------------------------------------- idput
        !          2335:     } elsif ($userinput =~ /^idput/) {
        !          2336: 	if(isClient) {
        !          2337: 	    my ($cmd,$udom,$what)=split(/:/,$userinput);
        !          2338: 	    chomp($what);
        !          2339: 	    $udom=~s/\W//g;
        !          2340: 	    my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
        !          2341: 	    my $now=time;
        !          2342: 	    my @pairs=split(/\&/,$what);
        !          2343: 	    my %hash;
        !          2344: 	    if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
        !          2345: 		{
        !          2346: 		    my $hfh;
        !          2347: 		    if ($hfh=IO::File->new(">>$proname.hist")) {
        !          2348: 			print $hfh "P:$now:$what\n";
        !          2349: 		    }
        !          2350: 		}
        !          2351: 		foreach my $pair (@pairs) {
        !          2352: 		    my ($key,$value)=split(/=/,$pair);
        !          2353: 		    $hash{$key}=$value;
        !          2354: 		}
        !          2355: 		if (untie(%hash)) {
        !          2356: 		    print $client "ok\n";
        !          2357: 		} else {
        !          2358: 		    print $client "error: ".($!+0)
        !          2359: 			." untie(GDBM) Failed ".
        !          2360: 			"while attempting idput\n";
        !          2361: 		}
        !          2362: 	    } else {
        !          2363: 		print $client "error: ".($!+0)
        !          2364: 		    ." tie(GDBM) Failed ".
        !          2365: 		    "while attempting idput\n";
        !          2366: 	    }
        !          2367: 	} else {
        !          2368: 	    Reply($client, "refused\n", $userinput);
        !          2369: 	    
        !          2370: 	}
        !          2371: # ----------------------------------------------------------------------- idget
        !          2372:     } elsif ($userinput =~ /^idget/) {
        !          2373: 	if(isClient) {
        !          2374: 	    my ($cmd,$udom,$what)=split(/:/,$userinput);
        !          2375: 	    chomp($what);
        !          2376: 	    $udom=~s/\W//g;
        !          2377: 	    my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
        !          2378: 	    my @queries=split(/\&/,$what);
        !          2379: 	    my $qresult='';
        !          2380: 	    my %hash;
        !          2381: 	    if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
        !          2382: 		for (my $i=0;$i<=$#queries;$i++) {
        !          2383: 		    $qresult.="$hash{$queries[$i]}&";
        !          2384: 		}
        !          2385: 		if (untie(%hash)) {
        !          2386: 		    $qresult=~s/\&$//;
        !          2387: 		    print $client "$qresult\n";
        !          2388: 		} else {
        !          2389: 		    print $client "error: ".($!+0)
        !          2390: 			." untie(GDBM) Failed ".
        !          2391: 			"while attempting idget\n";
        !          2392: 		}
        !          2393: 	    } else {
        !          2394: 		print $client "error: ".($!+0)
        !          2395: 		    ." tie(GDBM) Failed ".
        !          2396: 		    "while attempting idget\n";
        !          2397: 	    }
        !          2398: 	} else {
        !          2399: 	    Reply($client, "refused\n", $userinput);
        !          2400: 	    
        !          2401: 	}
        !          2402: # ---------------------------------------------------------------------- tmpput
        !          2403:     } elsif ($userinput =~ /^tmpput/) {
        !          2404: 	if(isClient) {
        !          2405: 	    my ($cmd,$what)=split(/:/,$userinput);
        !          2406: 	    my $store;
        !          2407: 	    $tmpsnum++;
        !          2408: 	    my $id=$$.'_'.$clientip.'_'.$tmpsnum;
        !          2409: 	    $id=~s/\W/\_/g;
        !          2410: 	    $what=~s/\n//g;
        !          2411: 	    my $execdir=$perlvar{'lonDaemons'};
        !          2412: 	    if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
        !          2413: 		print $store $what;
        !          2414: 		close $store;
        !          2415: 		print $client "$id\n";
        !          2416: 	    }
        !          2417: 	    else {
        !          2418: 		print $client "error: ".($!+0)
        !          2419: 		    ."IO::File->new Failed ".
        !          2420: 		    "while attempting tmpput\n";
        !          2421: 	    }
        !          2422: 	} else {
        !          2423: 	    Reply($client, "refused\n", $userinput);
        !          2424: 	    
        !          2425: 	}
        !          2426: 	
        !          2427: # ---------------------------------------------------------------------- tmpget
        !          2428:     } elsif ($userinput =~ /^tmpget/) {
        !          2429: 	if(isClient) {
        !          2430: 	    my ($cmd,$id)=split(/:/,$userinput);
        !          2431: 	    chomp($id);
        !          2432: 	    $id=~s/\W/\_/g;
        !          2433: 	    my $store;
        !          2434: 	    my $execdir=$perlvar{'lonDaemons'};
        !          2435: 	    if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
        !          2436: 		my $reply=<$store>;
        !          2437: 			    print $client "$reply\n";
        !          2438: 		close $store;
        !          2439: 	    }
        !          2440: 	    else {
        !          2441: 		print $client "error: ".($!+0)
        !          2442: 		    ."IO::File->new Failed ".
        !          2443: 		    "while attempting tmpget\n";
        !          2444: 	    }
        !          2445: 	} else {
        !          2446: 	    Reply($client, "refused\n", $userinput);
        !          2447: 	    
        !          2448: 	}
        !          2449: # ---------------------------------------------------------------------- tmpdel
        !          2450:     } elsif ($userinput =~ /^tmpdel/) {
        !          2451: 	if(isClient) {
        !          2452: 	    my ($cmd,$id)=split(/:/,$userinput);
        !          2453: 	    chomp($id);
        !          2454: 	    $id=~s/\W/\_/g;
        !          2455: 	    my $execdir=$perlvar{'lonDaemons'};
        !          2456: 	    if (unlink("$execdir/tmp/$id.tmp")) {
        !          2457: 		print $client "ok\n";
        !          2458: 	    } else {
        !          2459: 		print $client "error: ".($!+0)
        !          2460: 		    ."Unlink tmp Failed ".
        !          2461: 		    "while attempting tmpdel\n";
        !          2462: 	    }
        !          2463: 	} else {
        !          2464: 	    Reply($client, "refused\n", $userinput);
        !          2465: 	    
        !          2466: 	}
        !          2467: # ----------------------------------------- portfolio directory list (portls)
        !          2468:     } elsif ($userinput =~ /^portls/) {
        !          2469: 	if(isClient) {
        !          2470: 	    my ($cmd,$uname,$udom)=split(/:/,$userinput);
        !          2471: 	    my $udir=propath($udom,$uname).'/userfiles/portfolio';
        !          2472: 	    my $dirLine='';
        !          2473: 	    my $dirContents='';
        !          2474: 	    if (opendir(LSDIR,$udir.'/')){
        !          2475: 		while ($dirLine = readdir(LSDIR)){
        !          2476: 		    $dirContents = $dirContents.$dirLine.'<br />';
        !          2477: 		}
        !          2478: 	    } else {
        !          2479: 		$dirContents = "No directory found\n";
        !          2480: 	    }
        !          2481: 	    print $client $dirContents."\n";
        !          2482: 	} else {
        !          2483: 	    Reply($client, "refused\n", $userinput);
        !          2484: 	}
        !          2485: # -------------------------------------------------------------------------- ls
        !          2486:     } elsif ($userinput =~ /^ls/) {
        !          2487: 	if(isClient) {
        !          2488: 	    my $obs;
        !          2489: 	    my $rights;
        !          2490: 	    my ($cmd,$ulsdir)=split(/:/,$userinput);
        !          2491: 	    my $ulsout='';
        !          2492: 	    my $ulsfn;
        !          2493: 	    if (-e $ulsdir) {
        !          2494: 		if(-d $ulsdir) {
        !          2495: 		    if (opendir(LSDIR,$ulsdir)) {
        !          2496: 			while ($ulsfn=readdir(LSDIR)) {
        !          2497: 			    undef $obs, $rights; 
        !          2498: 			    my @ulsstats=stat($ulsdir.'/'.$ulsfn);
        !          2499: 			    #We do some obsolete checking here
        !          2500: 			    if(-e $ulsdir.'/'.$ulsfn.".meta") { 
        !          2501: 				open(FILE, $ulsdir.'/'.$ulsfn.".meta");
        !          2502: 				my @obsolete=<FILE>;
        !          2503: 				foreach my $obsolete (@obsolete) {
        !          2504: 				    if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } 
        !          2505: 				    if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
        !          2506: 				}
        !          2507: 			    }
        !          2508: 			    $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
        !          2509: 			    if($obs eq '1') { $ulsout.="&1"; }
        !          2510: 			    else { $ulsout.="&0"; }
        !          2511: 			    if($rights eq '1') { $ulsout.="&1:"; }
        !          2512: 			    else { $ulsout.="&0:"; }
        !          2513: 			}
        !          2514: 			closedir(LSDIR);
        !          2515: 		    }
        !          2516: 		} else {
        !          2517: 		    my @ulsstats=stat($ulsdir);
        !          2518: 		    $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
        !          2519: 		}
        !          2520: 	    } else {
        !          2521: 		$ulsout='no_such_dir';
        !          2522: 	    }
        !          2523: 	    if ($ulsout eq '') { $ulsout='empty'; }
        !          2524: 	    print $client "$ulsout\n";
        !          2525: 	} else {
        !          2526: 	    Reply($client, "refused\n", $userinput);
        !          2527: 	    
        !          2528: 	}
        !          2529: # ----------------------------------------------------------------- setannounce
        !          2530:     } elsif ($userinput =~ /^setannounce/) {
        !          2531: 	if (isClient) {
        !          2532: 	    my ($cmd,$announcement)=split(/:/,$userinput);
        !          2533: 	    chomp($announcement);
        !          2534: 	    $announcement=&unescape($announcement);
        !          2535: 	    if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
        !          2536: 					'/announcement.txt')) {
        !          2537: 		print $store $announcement;
        !          2538: 		close $store;
        !          2539: 		print $client "ok\n";
        !          2540: 	    } else {
        !          2541: 		print $client "error: ".($!+0)."\n";
        !          2542: 	    }
        !          2543: 	} else {
        !          2544: 	    Reply($client, "refused\n", $userinput);
        !          2545: 	    
        !          2546: 	}
        !          2547: # ------------------------------------------------------------------ Hanging up
        !          2548:     } elsif (($userinput =~ /^exit/) ||
        !          2549: 	     ($userinput =~ /^init/)) { # no restrictions.
        !          2550: 	&logthis(
        !          2551: 		 "Client $clientip ($clientname) hanging up: $userinput");
        !          2552: 	print $client "bye\n";
        !          2553: 	$client->shutdown(2);        # shutdown the socket forcibly.
        !          2554: 	$client->close();
        !          2555: 	return 0;
        !          2556: 	
        !          2557: # ---------------------------------- set current host/domain
        !          2558:     } elsif ($userinput =~ /^sethost:/) {
        !          2559: 	if (isClient) {
        !          2560: 	    print $client &sethost($userinput)."\n";
        !          2561: 	} else {
        !          2562: 	    print $client "refused\n";
        !          2563: 	}
        !          2564: #---------------------------------- request file (?) version.
        !          2565:     } elsif ($userinput =~/^version:/) {
        !          2566: 	if (isClient) {
        !          2567: 	    print $client &version($userinput)."\n";
        !          2568: 	} else {
        !          2569: 	    print $client "refused\n";
        !          2570: 	}
        !          2571: #------------------------------- is auto-enrollment enabled?
        !          2572:     } elsif ($userinput =~/^autorun:/) {
        !          2573: 	if (isClient) {
        !          2574: 	    my ($cmd,$cdom) = split(/:/,$userinput);
        !          2575: 	    my $outcome = &localenroll::run($cdom);
        !          2576: 	    print $client "$outcome\n";
        !          2577: 	} else {
        !          2578: 	    print $client "0\n";
        !          2579: 	}
        !          2580: #------------------------------- get official sections (for auto-enrollment).
        !          2581:     } elsif ($userinput =~/^autogetsections:/) {
        !          2582: 	if (isClient) {
        !          2583: 	    my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
        !          2584: 	    my @secs = &localenroll::get_sections($coursecode,$cdom);
        !          2585: 	    my $seclist = &escape(join(':',@secs));
        !          2586: 	    print $client "$seclist\n";
        !          2587: 	} else {
        !          2588: 	    print $client "refused\n";
        !          2589: 	}
        !          2590: #----------------------- validate owner of new course section (for auto-enrollment).
        !          2591:     } elsif ($userinput =~/^autonewcourse:/) {
        !          2592: 	if (isClient) {
        !          2593: 	    my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
        !          2594: 	    my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
        !          2595: 	    print $client "$outcome\n";
        !          2596: 	} else {
        !          2597: 	    print $client "refused\n";
        !          2598: 	}
        !          2599: #-------------- validate course section in schedule of classes (for auto-enrollment).
        !          2600:     } elsif ($userinput =~/^autovalidatecourse:/) {
        !          2601: 	if (isClient) {
        !          2602: 	    my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
        !          2603: 	    my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
        !          2604: 	    print $client "$outcome\n";
        !          2605: 	} else {
        !          2606: 	    print $client "refused\n";
        !          2607: 	}
        !          2608: #--------------------------- create password for new user (for auto-enrollment).
        !          2609:     } elsif ($userinput =~/^autocreatepassword:/) {
        !          2610: 	if (isClient) {
        !          2611: 	    my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
        !          2612: 	    my ($create_passwd,$authchk);
        !          2613: 	    ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);
        !          2614: 	    print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
        !          2615: 	} else {
        !          2616: 	    print $client "refused\n";
        !          2617: 	}
        !          2618: #---------------------------  read and remove temporary files (for auto-enrollment).
        !          2619:     } elsif ($userinput =~/^autoretrieve:/) {
        !          2620: 	if (isClient) {
        !          2621: 	    my ($cmd,$filename) = split(/:/,$userinput);
        !          2622: 	    my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
        !          2623: 	    if ( (-e $source) && ($filename ne '') ) {
        !          2624: 		my $reply = '';
        !          2625: 		if (open(my $fh,$source)) {
        !          2626: 		    while (<$fh>) {
        !          2627: 			chomp($_);
        !          2628: 			$_ =~ s/^\s+//g;
        !          2629: 			$_ =~ s/\s+$//g;
        !          2630: 			$reply .= $_;
        !          2631: 		    }
        !          2632: 		    close($fh);
        !          2633: 		    print $client &escape($reply)."\n";
        !          2634: #                                unlink($source);
        !          2635: 		} else {
        !          2636: 		    print $client "error\n";
        !          2637: 		}
        !          2638: 	    } else {
        !          2639: 		print $client "error\n";
        !          2640: 	    }
        !          2641: 	} else {
        !          2642: 	    print $client "refused\n";
        !          2643: 	}
        !          2644: #---------------------  read and retrieve institutional code format (for support form).
        !          2645:     } elsif ($userinput =~/^autoinstcodeformat:/) {
        !          2646: 	if (isClient) {
        !          2647: 	    my $reply;
        !          2648: 	    my($cmd,$cdom,$course) = split(/:/,$userinput);
        !          2649: 	    my @pairs = split/\&/,$course;
        !          2650: 	    my %instcodes = ();
        !          2651: 	    my %codes = ();
        !          2652: 	    my @codetitles = ();
        !          2653: 	    my %cat_titles = ();
        !          2654: 	    my %cat_order = ();
        !          2655: 	    foreach (@pairs) {
        !          2656: 		my ($key,$value) = split/=/,$_;
        !          2657: 		$instcodes{&unescape($key)} = &unescape($value);
        !          2658: 	    }
        !          2659: 	    my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order);
        !          2660: 	    if ($formatreply eq 'ok') {
        !          2661: 		my $codes_str = &hash2str(%codes);
        !          2662: 		my $codetitles_str = &array2str(@codetitles);
        !          2663: 		my $cat_titles_str = &hash2str(%cat_titles);
        !          2664: 		my $cat_order_str = &hash2str(%cat_order);
        !          2665: 		print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";
        !          2666: 	    }
        !          2667: 	} else {
        !          2668: 	    print $client "refused\n";
        !          2669: 	}
        !          2670: # ------------------------------------------------------------- unknown command
        !          2671: 	
        !          2672:     } else {
        !          2673: 	# unknown command
        !          2674: 	print $client "unknown_cmd\n";
        !          2675:     }
        !          2676: # -------------------------------------------------------------------- complete
        !          2677:     Debug("process_request - returning 1");
        !          2678:     return 1;
        !          2679: }
1.207     foxr     2680: #
                   2681: #   Decipher encoded traffic
                   2682: #  Parameters:
                   2683: #     input      - Encoded data.
                   2684: #  Returns:
                   2685: #     Decoded data or undef if encryption key was not yet negotiated.
                   2686: #  Implicit input:
                   2687: #     cipher  - This global holds the negotiated encryption key.
                   2688: #
1.211     albertel 2689: sub decipher {
1.207     foxr     2690:     my ($input)  = @_;
                   2691:     my $output = '';
1.212   ! foxr     2692:     
        !          2693:     
1.207     foxr     2694:     if($cipher) {
                   2695: 	my($enc, $enclength, $encinput) = split(/:/, $input);
                   2696: 	for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {
                   2697: 	    $output .= 
                   2698: 		$cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));
                   2699: 	}
                   2700: 	return substr($output, 0, $enclength);
                   2701:     } else {
                   2702: 	return undef;
                   2703:     }
                   2704: }
                   2705: 
                   2706: #
                   2707: #   Register a command processor.  This function is invoked to register a sub
                   2708: #   to process a request.  Once registered, the ProcessRequest sub can automatically
                   2709: #   dispatch requests to an appropriate sub, and do the top level validity checking
                   2710: #   as well:
                   2711: #    - Is the keyword recognized.
                   2712: #    - Is the proper client type attempting the request.
                   2713: #    - Is the request encrypted if it has to be.
                   2714: #   Parameters:
                   2715: #    $request_name         - Name of the request being registered.
                   2716: #                           This is the command request that will match
                   2717: #                           against the hash keywords to lookup the information
                   2718: #                           associated with the dispatch information.
                   2719: #    $procedure           - Reference to a sub to call to process the request.
                   2720: #                           All subs get called as follows:
                   2721: #                             Procedure($cmd, $tail, $replyfd, $key)
                   2722: #                             $cmd    - the actual keyword that invoked us.
                   2723: #                             $tail   - the tail of the request that invoked us.
                   2724: #                             $replyfd- File descriptor connected to the client
                   2725: #    $must_encode          - True if the request must be encoded to be good.
                   2726: #    $client_ok            - True if it's ok for a client to request this.
                   2727: #    $manager_ok           - True if it's ok for a manager to request this.
                   2728: # Side effects:
                   2729: #      - On success, the Dispatcher hash has an entry added for the key $RequestName
                   2730: #      - On failure, the program will die as it's a bad internal bug to try to 
                   2731: #        register a duplicate command handler.
                   2732: #
1.211     albertel 2733: sub register_handler {
1.212   ! foxr     2734:     my ($request_name,$procedure,$must_encode,	$client_ok,$manager_ok)   = @_;
1.207     foxr     2735: 
                   2736:     #  Don't allow duplication#
                   2737:    
                   2738:     if (defined $Dispatcher{$request_name}) {
                   2739: 	die "Attempting to define a duplicate request handler for $request_name\n";
                   2740:     }
                   2741:     #   Build the client type mask:
                   2742:     
                   2743:     my $client_type_mask = 0;
                   2744:     if($client_ok) {
                   2745: 	$client_type_mask  |= $CLIENT_OK;
                   2746:     }
                   2747:     if($manager_ok) {
                   2748: 	$client_type_mask  |= $MANAGER_OK;
                   2749:     }
                   2750:    
                   2751:     #  Enter the hash:
                   2752:       
                   2753:     my @entry = ($procedure, $must_encode, $client_type_mask);
                   2754:    
                   2755:     $Dispatcher{$request_name} = \@entry;
                   2756:    
                   2757:    
                   2758: }
                   2759: 
                   2760: 
                   2761: #------------------------------------------------------------------
                   2762: 
                   2763: 
                   2764: 
                   2765: 
1.141     foxr     2766: #
1.96      foxr     2767: #  Convert an error return code from lcpasswd to a string value.
                   2768: #
                   2769: sub lcpasswdstrerror {
                   2770:     my $ErrorCode = shift;
1.97      foxr     2771:     if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
1.96      foxr     2772: 	return "lcpasswd Unrecognized error return value ".$ErrorCode;
                   2773:     } else {
1.98      foxr     2774: 	return $passwderrors[$ErrorCode];
1.96      foxr     2775:     }
                   2776: }
                   2777: 
1.97      foxr     2778: #
                   2779: # Convert an error return code from lcuseradd to a string value:
                   2780: #
                   2781: sub lcuseraddstrerror {
                   2782:     my $ErrorCode = shift;
                   2783:     if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
                   2784: 	return "lcuseradd - Unrecognized error code: ".$ErrorCode;
                   2785:     } else {
1.98      foxr     2786: 	return $adderrors[$ErrorCode];
1.97      foxr     2787:     }
                   2788: }
                   2789: 
1.23      harris41 2790: # grabs exception and records it to log before exiting
                   2791: sub catchexception {
1.27      albertel 2792:     my ($error)=@_;
1.25      www      2793:     $SIG{'QUIT'}='DEFAULT';
                   2794:     $SIG{__DIE__}='DEFAULT';
1.165     albertel 2795:     &status("Catching exception");
1.190     albertel 2796:     &logthis("<font color='red'>CRITICAL: "
1.134     albertel 2797:      ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
1.27      albertel 2798:      ."a crash with this error msg->[$error]</font>");
1.57      www      2799:     &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27      albertel 2800:     if ($client) { print $client "error: $error\n"; }
1.59      www      2801:     $server->close();
1.27      albertel 2802:     die($error);
1.23      harris41 2803: }
                   2804: 
1.63      www      2805: sub timeout {
1.165     albertel 2806:     &status("Handling Timeout");
1.190     albertel 2807:     &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
1.63      www      2808:     &catchexception('Timeout');
                   2809: }
1.22      harris41 2810: # -------------------------------- Set signal handlers to record abnormal exits
                   2811: 
                   2812: $SIG{'QUIT'}=\&catchexception;
                   2813: $SIG{__DIE__}=\&catchexception;
                   2814: 
1.81      matthew  2815: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
1.95      harris41 2816: &status("Read loncapa.conf and loncapa_apache.conf");
                   2817: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.141     foxr     2818: %perlvar=%{$perlvarref};
1.80      harris41 2819: undef $perlvarref;
1.19      www      2820: 
1.35      harris41 2821: # ----------------------------- Make sure this process is running from user=www
                   2822: my $wwwid=getpwnam('www');
                   2823: if ($wwwid!=$<) {
1.134     albertel 2824:    my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
                   2825:    my $subj="LON: $currenthostid User ID mismatch";
1.37      harris41 2826:    system("echo 'User ID mismatch.  lond must be run as user www.' |\
1.35      harris41 2827:  mailto $emailto -s '$subj' > /dev/null");
                   2828:    exit 1;
                   2829: }
                   2830: 
1.19      www      2831: # --------------------------------------------- Check if other instance running
                   2832: 
                   2833: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
                   2834: 
                   2835: if (-e $pidfile) {
                   2836:    my $lfh=IO::File->new("$pidfile");
                   2837:    my $pide=<$lfh>;
                   2838:    chomp($pide);
1.29      harris41 2839:    if (kill 0 => $pide) { die "already running"; }
1.19      www      2840: }
1.1       albertel 2841: 
                   2842: # ------------------------------------------------------------- Read hosts file
                   2843: 
                   2844: 
                   2845: 
                   2846: # establish SERVER socket, bind and listen.
                   2847: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
                   2848:                                 Type      => SOCK_STREAM,
                   2849:                                 Proto     => 'tcp',
                   2850:                                 Reuse     => 1,
                   2851:                                 Listen    => 10 )
1.29      harris41 2852:   or die "making socket: $@\n";
1.1       albertel 2853: 
                   2854: # --------------------------------------------------------- Do global variables
                   2855: 
                   2856: # global variables
                   2857: 
1.134     albertel 2858: my %children               = ();       # keys are current child process IDs
1.1       albertel 2859: 
                   2860: sub REAPER {                        # takes care of dead children
                   2861:     $SIG{CHLD} = \&REAPER;
1.165     albertel 2862:     &status("Handling child death");
1.178     foxr     2863:     my $pid;
                   2864:     do {
                   2865: 	$pid = waitpid(-1,&WNOHANG());
                   2866: 	if (defined($children{$pid})) {
                   2867: 	    &logthis("Child $pid died");
                   2868: 	    delete($children{$pid});
1.183     albertel 2869: 	} elsif ($pid > 0) {
1.178     foxr     2870: 	    &logthis("Unknown Child $pid died");
                   2871: 	}
                   2872:     } while ( $pid > 0 );
                   2873:     foreach my $child (keys(%children)) {
                   2874: 	$pid = waitpid($child,&WNOHANG());
                   2875: 	if ($pid > 0) {
                   2876: 	    &logthis("Child $child - $pid looks like we missed it's death");
                   2877: 	    delete($children{$pid});
                   2878: 	}
1.176     albertel 2879:     }
1.165     albertel 2880:     &status("Finished Handling child death");
1.1       albertel 2881: }
                   2882: 
                   2883: sub HUNTSMAN {                      # signal handler for SIGINT
1.165     albertel 2884:     &status("Killing children (INT)");
1.1       albertel 2885:     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
                   2886:     kill 'INT' => keys %children;
1.59      www      2887:     &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1       albertel 2888:     my $execdir=$perlvar{'lonDaemons'};
                   2889:     unlink("$execdir/logs/lond.pid");
1.190     albertel 2890:     &logthis("<font color='red'>CRITICAL: Shutting down</font>");
1.165     albertel 2891:     &status("Done killing children");
1.1       albertel 2892:     exit;                           # clean up with dignity
                   2893: }
                   2894: 
                   2895: sub HUPSMAN {                      # signal handler for SIGHUP
                   2896:     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
1.165     albertel 2897:     &status("Killing children for restart (HUP)");
1.1       albertel 2898:     kill 'INT' => keys %children;
1.59      www      2899:     &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.190     albertel 2900:     &logthis("<font color='red'>CRITICAL: Restarting</font>");
1.134     albertel 2901:     my $execdir=$perlvar{'lonDaemons'};
1.30      harris41 2902:     unlink("$execdir/logs/lond.pid");
1.165     albertel 2903:     &status("Restarting self (HUP)");
1.1       albertel 2904:     exec("$execdir/lond");         # here we go again
                   2905: }
                   2906: 
1.144     foxr     2907: #
1.148     foxr     2908: #    Kill off hashes that describe the host table prior to re-reading it.
                   2909: #    Hashes affected are:
1.200     matthew  2910: #       %hostid, %hostdom %hostip %hostdns.
1.148     foxr     2911: #
                   2912: sub KillHostHashes {
                   2913:     foreach my $key (keys %hostid) {
                   2914: 	delete $hostid{$key};
                   2915:     }
                   2916:     foreach my $key (keys %hostdom) {
                   2917: 	delete $hostdom{$key};
                   2918:     }
                   2919:     foreach my $key (keys %hostip) {
                   2920: 	delete $hostip{$key};
                   2921:     }
1.200     matthew  2922:     foreach my $key (keys %hostdns) {
                   2923: 	delete $hostdns{$key};
                   2924:     }
1.148     foxr     2925: }
                   2926: #
                   2927: #   Read in the host table from file and distribute it into the various hashes:
                   2928: #
                   2929: #    - %hostid  -  Indexed by IP, the loncapa hostname.
                   2930: #    - %hostdom -  Indexed by  loncapa hostname, the domain.
                   2931: #    - %hostip  -  Indexed by hostid, the Ip address of the host.
                   2932: sub ReadHostTable {
                   2933: 
                   2934:     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
1.200     matthew  2935:     my $myloncapaname = $perlvar{'lonHostID'};
                   2936:     Debug("My loncapa name is : $myloncapaname");
1.148     foxr     2937:     while (my $configline=<CONFIG>) {
1.178     foxr     2938: 	if (!($configline =~ /^\s*\#/)) {
                   2939: 	    my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
                   2940: 	    chomp($ip); $ip=~s/\D+$//;
1.200     matthew  2941: 	    $hostid{$ip}=$id;         # LonCAPA name of host by IP.
                   2942: 	    $hostdom{$id}=$domain;    # LonCAPA domain name of host. 
                   2943: 	    $hostip{$id}=$ip;	      # IP address of host.
                   2944: 	    $hostdns{$name} = $id;    # LonCAPA name of host by DNS.
                   2945: 
                   2946: 	    if ($id eq $perlvar{'lonHostID'}) { 
                   2947: 		Debug("Found me in the host table: $name");
                   2948: 		$thisserver=$name; 
                   2949: 	    }
1.178     foxr     2950: 	}
1.148     foxr     2951:     }
                   2952:     close(CONFIG);
                   2953: }
                   2954: #
                   2955: #  Reload the Apache daemon's state.
1.150     foxr     2956: #  This is done by invoking /home/httpd/perl/apachereload
                   2957: #  a setuid perl script that can be root for us to do this job.
1.148     foxr     2958: #
                   2959: sub ReloadApache {
1.150     foxr     2960:     my $execdir = $perlvar{'lonDaemons'};
                   2961:     my $script  = $execdir."/apachereload";
                   2962:     system($script);
1.148     foxr     2963: }
                   2964: 
                   2965: #
1.144     foxr     2966: #   Called in response to a USR2 signal.
                   2967: #   - Reread hosts.tab
                   2968: #   - All children connected to hosts that were removed from hosts.tab
                   2969: #     are killed via SIGINT
                   2970: #   - All children connected to previously existing hosts are sent SIGUSR1
                   2971: #   - Our internal hosts hash is updated to reflect the new contents of
                   2972: #     hosts.tab causing connections from hosts added to hosts.tab to
                   2973: #     now be honored.
                   2974: #
                   2975: sub UpdateHosts {
1.165     albertel 2976:     &status("Reload hosts.tab");
1.147     foxr     2977:     logthis('<font color="blue"> Updating connections </font>');
1.148     foxr     2978:     #
                   2979:     #  The %children hash has the set of IP's we currently have children
                   2980:     #  on.  These need to be matched against records in the hosts.tab
                   2981:     #  Any ip's no longer in the table get killed off they correspond to
                   2982:     #  either dropped or changed hosts.  Note that the re-read of the table
                   2983:     #  will take care of new and changed hosts as connections come into being.
                   2984: 
                   2985: 
                   2986:     KillHostHashes;
                   2987:     ReadHostTable;
                   2988: 
                   2989:     foreach my $child (keys %children) {
                   2990: 	my $childip = $children{$child};
                   2991: 	if(!$hostid{$childip}) {
1.149     foxr     2992: 	    logthis('<font color="blue"> UpdateHosts killing child '
                   2993: 		    ." $child for ip $childip </font>");
1.148     foxr     2994: 	    kill('INT', $child);
1.149     foxr     2995: 	} else {
                   2996: 	    logthis('<font color="green"> keeping child for ip '
                   2997: 		    ." $childip (pid=$child) </font>");
1.148     foxr     2998: 	}
                   2999:     }
                   3000:     ReloadApache;
1.165     albertel 3001:     &status("Finished reloading hosts.tab");
1.144     foxr     3002: }
                   3003: 
1.148     foxr     3004: 
1.57      www      3005: sub checkchildren {
1.165     albertel 3006:     &status("Checking on the children (sending signals)");
1.57      www      3007:     &initnewstatus();
                   3008:     &logstatus();
                   3009:     &logthis('Going to check on the children');
1.134     albertel 3010:     my $docdir=$perlvar{'lonDocRoot'};
1.61      harris41 3011:     foreach (sort keys %children) {
1.57      www      3012: 	sleep 1;
                   3013:         unless (kill 'USR1' => $_) {
                   3014: 	    &logthis ('Child '.$_.' is dead');
                   3015:             &logstatus($$.' is dead');
                   3016:         } 
1.61      harris41 3017:     }
1.63      www      3018:     sleep 5;
1.212   ! foxr     3019:     $SIG{ALRM} = sub { Debug("timeout"); 
        !          3020: 		       die "timeout";  };
1.113     albertel 3021:     $SIG{__DIE__} = 'DEFAULT';
1.165     albertel 3022:     &status("Checking on the children (waiting for reports)");
1.63      www      3023:     foreach (sort keys %children) {
                   3024:         unless (-e "$docdir/lon-status/londchld/$_.txt") {
1.113     albertel 3025:           eval {
                   3026:             alarm(300);
1.63      www      3027: 	    &logthis('Child '.$_.' did not respond');
1.67      albertel 3028: 	    kill 9 => $_;
1.131     albertel 3029: 	    #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
                   3030: 	    #$subj="LON: $currenthostid killed lond process $_";
                   3031: 	    #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
                   3032: 	    #$execdir=$perlvar{'lonDaemons'};
                   3033: 	    #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
1.113     albertel 3034: 	    alarm(0);
                   3035: 	  }
1.63      www      3036:         }
                   3037:     }
1.113     albertel 3038:     $SIG{ALRM} = 'DEFAULT';
1.155     albertel 3039:     $SIG{__DIE__} = \&catchexception;
1.165     albertel 3040:     &status("Finished checking children");
1.57      www      3041: }
                   3042: 
1.1       albertel 3043: # --------------------------------------------------------------------- Logging
                   3044: 
                   3045: sub logthis {
                   3046:     my $message=shift;
                   3047:     my $execdir=$perlvar{'lonDaemons'};
                   3048:     my $fh=IO::File->new(">>$execdir/logs/lond.log");
                   3049:     my $now=time;
                   3050:     my $local=localtime($now);
1.58      www      3051:     $lastlog=$local.': '.$message;
1.1       albertel 3052:     print $fh "$local ($$): $message\n";
                   3053: }
                   3054: 
1.77      foxr     3055: # ------------------------- Conditional log if $DEBUG true.
                   3056: sub Debug {
                   3057:     my $message = shift;
                   3058:     if($DEBUG) {
                   3059: 	&logthis($message);
                   3060:     }
                   3061: }
1.161     foxr     3062: 
                   3063: #
                   3064: #   Sub to do replies to client.. this gives a hook for some
                   3065: #   debug tracing too:
                   3066: #  Parameters:
                   3067: #     fd      - File open on client.
                   3068: #     reply   - Text to send to client.
                   3069: #     request - Original request from client.
                   3070: #
                   3071: sub Reply {
1.212   ! foxr     3072:     alarm(120);
        !          3073:     my $fd      = shift;
        !          3074:     my $reply   = shift;
        !          3075:     my $request = shift;
1.192     foxr     3076: 
                   3077:     my ($fd, $reply, $request) = @_;
1.161     foxr     3078:     print $fd $reply;
                   3079:     Debug("Request was $request  Reply was $reply");
                   3080: 
1.212   ! foxr     3081:     $Transactions++;
        !          3082:     alarm(0);
        !          3083: 
        !          3084: 
        !          3085: }
        !          3086: 
        !          3087: 
        !          3088: #
        !          3089: #    Sub to report a failure.
        !          3090: #    This function:
        !          3091: #     -   Increments the failure statistic counters.
        !          3092: #     -   Invokes Reply to send the error message to the client.
        !          3093: # Parameters:
        !          3094: #    fd       - File descriptor open on the client
        !          3095: #    reply    - Reply text to emit.
        !          3096: #    request  - The original request message (used by Reply
        !          3097: #               to debug if that's enabled.
        !          3098: # Implicit outputs:
        !          3099: #    $Failures- The number of failures is incremented.
        !          3100: #    Reply (invoked here) sends a message to the 
        !          3101: #    client:
        !          3102: #
        !          3103: sub Failure {
        !          3104:     my $fd      = shift;
        !          3105:     my $reply   = shift;
        !          3106:     my $request = shift;
        !          3107:    
        !          3108:     $Failures++;
        !          3109:     Reply($fd, $reply, $request);      # That's simple eh?
1.161     foxr     3110: }
1.57      www      3111: # ------------------------------------------------------------------ Log status
                   3112: 
                   3113: sub logstatus {
1.178     foxr     3114:     &status("Doing logging");
                   3115:     my $docdir=$perlvar{'lonDocRoot'};
                   3116:     {
                   3117:     my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
1.200     matthew  3118:     print $fh $$."\t".$clientname."\t".$currenthostid."\t"
                   3119: 	.$status."\t".$lastlog."\t $keymode\n";
1.178     foxr     3120:     $fh->close();
                   3121:     }
                   3122:     &status("Finished londstatus.txt");
                   3123:     {
                   3124: 	my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
1.200     matthew  3125:         print $fh $status."\n".$lastlog."\n".time."\n$keymode";
1.178     foxr     3126:         $fh->close();
                   3127:     }
                   3128:     &status("Finished logging");
1.57      www      3129: }
                   3130: 
                   3131: sub initnewstatus {
                   3132:     my $docdir=$perlvar{'lonDocRoot'};
                   3133:     my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
                   3134:     my $now=time;
                   3135:     my $local=localtime($now);
                   3136:     print $fh "LOND status $local - parent $$\n\n";
1.64      www      3137:     opendir(DIR,"$docdir/lon-status/londchld");
1.134     albertel 3138:     while (my $filename=readdir(DIR)) {
1.64      www      3139:         unlink("$docdir/lon-status/londchld/$filename");
                   3140:     }
                   3141:     closedir(DIR);
1.57      www      3142: }
                   3143: 
                   3144: # -------------------------------------------------------------- Status setting
                   3145: 
                   3146: sub status {
                   3147:     my $what=shift;
                   3148:     my $now=time;
                   3149:     my $local=localtime($now);
1.178     foxr     3150:     $status=$local.': '.$what;
                   3151:     $0='lond: '.$what.' '.$local;
1.57      www      3152: }
1.11      www      3153: 
                   3154: # -------------------------------------------------------- Escape Special Chars
                   3155: 
                   3156: sub escape {
                   3157:     my $str=shift;
                   3158:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                   3159:     return $str;
                   3160: }
                   3161: 
                   3162: # ----------------------------------------------------- Un-Escape Special Chars
                   3163: 
                   3164: sub unescape {
                   3165:     my $str=shift;
                   3166:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                   3167:     return $str;
                   3168: }
                   3169: 
1.1       albertel 3170: # ----------------------------------------------------------- Send USR1 to lonc
                   3171: 
                   3172: sub reconlonc {
                   3173:     my $peerfile=shift;
                   3174:     &logthis("Trying to reconnect for $peerfile");
                   3175:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
                   3176:     if (my $fh=IO::File->new("$loncfile")) {
                   3177: 	my $loncpid=<$fh>;
                   3178:         chomp($loncpid);
                   3179:         if (kill 0 => $loncpid) {
                   3180: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
                   3181:             kill USR1 => $loncpid;
                   3182:         } else {
1.9       www      3183: 	    &logthis(
1.190     albertel 3184:               "<font color='red'>CRITICAL: "
1.9       www      3185:              ."lonc at pid $loncpid not responding, giving up</font>");
1.1       albertel 3186:         }
                   3187:     } else {
1.190     albertel 3188:       &logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
1.1       albertel 3189:     }
                   3190: }
                   3191: 
                   3192: # -------------------------------------------------- Non-critical communication
1.11      www      3193: 
1.1       albertel 3194: sub subreply {
                   3195:     my ($cmd,$server)=@_;
                   3196:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                   3197:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                   3198:                                       Type    => SOCK_STREAM,
                   3199:                                       Timeout => 10)
                   3200:        or return "con_lost";
                   3201:     print $sclient "$cmd\n";
                   3202:     my $answer=<$sclient>;
                   3203:     chomp($answer);
                   3204:     if (!$answer) { $answer="con_lost"; }
                   3205:     return $answer;
                   3206: }
                   3207: 
                   3208: sub reply {
                   3209:   my ($cmd,$server)=@_;
                   3210:   my $answer;
1.115     albertel 3211:   if ($server ne $currenthostid) { 
1.1       albertel 3212:     $answer=subreply($cmd,$server);
                   3213:     if ($answer eq 'con_lost') {
                   3214: 	$answer=subreply("ping",$server);
                   3215:         if ($answer ne $server) {
1.115     albertel 3216: 	    &logthis("sub reply: answer != server answer is $answer, server is $server");
1.1       albertel 3217:            &reconlonc("$perlvar{'lonSockDir'}/$server");
                   3218:         }
                   3219:         $answer=subreply($cmd,$server);
                   3220:     }
                   3221:   } else {
                   3222:     $answer='self_reply';
                   3223:   } 
                   3224:   return $answer;
                   3225: }
                   3226: 
1.13      www      3227: # -------------------------------------------------------------- Talk to lonsql
                   3228: 
1.12      harris41 3229: sub sqlreply {
                   3230:     my ($cmd)=@_;
                   3231:     my $answer=subsqlreply($cmd);
                   3232:     if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
                   3233:     return $answer;
                   3234: }
                   3235: 
                   3236: sub subsqlreply {
                   3237:     my ($cmd)=@_;
                   3238:     my $unixsock="mysqlsock";
                   3239:     my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
                   3240:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                   3241:                                       Type    => SOCK_STREAM,
                   3242:                                       Timeout => 10)
                   3243:        or return "con_lost";
                   3244:     print $sclient "$cmd\n";
                   3245:     my $answer=<$sclient>;
                   3246:     chomp($answer);
                   3247:     if (!$answer) { $answer="con_lost"; }
                   3248:     return $answer;
                   3249: }
                   3250: 
1.1       albertel 3251: # -------------------------------------------- Return path to profile directory
1.11      www      3252: 
1.1       albertel 3253: sub propath {
                   3254:     my ($udom,$uname)=@_;
                   3255:     $udom=~s/\W//g;
                   3256:     $uname=~s/\W//g;
1.16      www      3257:     my $subdir=$uname.'__';
1.1       albertel 3258:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
                   3259:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
                   3260:     return $proname;
                   3261: } 
                   3262: 
                   3263: # --------------------------------------- Is this the home server of an author?
1.11      www      3264: 
1.1       albertel 3265: sub ishome {
                   3266:     my $author=shift;
                   3267:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                   3268:     my ($udom,$uname)=split(/\//,$author);
                   3269:     my $proname=propath($udom,$uname);
                   3270:     if (-e $proname) {
                   3271: 	return 'owner';
                   3272:     } else {
                   3273:         return 'not_owner';
                   3274:     }
                   3275: }
                   3276: 
                   3277: # ======================================================= Continue main program
                   3278: # ---------------------------------------------------- Fork once and dissociate
                   3279: 
1.134     albertel 3280: my $fpid=fork;
1.1       albertel 3281: exit if $fpid;
1.29      harris41 3282: die "Couldn't fork: $!" unless defined ($fpid);
1.1       albertel 3283: 
1.29      harris41 3284: POSIX::setsid() or die "Can't start new session: $!";
1.1       albertel 3285: 
                   3286: # ------------------------------------------------------- Write our PID on disk
                   3287: 
1.134     albertel 3288: my $execdir=$perlvar{'lonDaemons'};
1.1       albertel 3289: open (PIDSAVE,">$execdir/logs/lond.pid");
                   3290: print PIDSAVE "$$\n";
                   3291: close(PIDSAVE);
1.190     albertel 3292: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
1.57      www      3293: &status('Starting');
1.1       albertel 3294: 
1.106     foxr     3295: 
1.1       albertel 3296: 
                   3297: # ----------------------------------------------------- Install signal handlers
                   3298: 
1.57      www      3299: 
1.1       albertel 3300: $SIG{CHLD} = \&REAPER;
                   3301: $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
                   3302: $SIG{HUP}  = \&HUPSMAN;
1.57      www      3303: $SIG{USR1} = \&checkchildren;
1.144     foxr     3304: $SIG{USR2} = \&UpdateHosts;
1.106     foxr     3305: 
1.148     foxr     3306: #  Read the host hashes:
                   3307: 
                   3308: ReadHostTable;
1.106     foxr     3309: 
                   3310: # --------------------------------------------------------------
                   3311: #   Accept connections.  When a connection comes in, it is validated
                   3312: #   and if good, a child process is created to process transactions
                   3313: #   along the connection.
                   3314: 
1.1       albertel 3315: while (1) {
1.165     albertel 3316:     &status('Starting accept');
1.106     foxr     3317:     $client = $server->accept() or next;
1.165     albertel 3318:     &status('Accepted '.$client.' off to spawn');
1.106     foxr     3319:     make_new_child($client);
1.165     albertel 3320:     &status('Finished spawning');
1.1       albertel 3321: }
                   3322: 
1.212   ! foxr     3323: sub make_new_child {
        !          3324:     my $pid;
        !          3325: #    my $cipher;     # Now global
        !          3326:     my $sigset;
1.178     foxr     3327: 
1.212   ! foxr     3328:     $client = shift;
        !          3329:     &status('Starting new child '.$client);
        !          3330:     &logthis('<font color="green"> Attempting to start child ('.$client.
        !          3331: 	     ")</font>");    
        !          3332:     # block signal for fork
        !          3333:     $sigset = POSIX::SigSet->new(SIGINT);
        !          3334:     sigprocmask(SIG_BLOCK, $sigset)
        !          3335:         or die "Can't block SIGINT for fork: $!\n";
1.178     foxr     3336: 
1.212   ! foxr     3337:     die "fork: $!" unless defined ($pid = fork);
1.178     foxr     3338: 
1.212   ! foxr     3339:     $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
        !          3340: 	                               # connection liveness.
1.178     foxr     3341: 
1.212   ! foxr     3342:     #
        !          3343:     #  Figure out who we're talking to so we can record the peer in 
        !          3344:     #  the pid hash.
        !          3345:     #
        !          3346:     my $caller = getpeername($client);
        !          3347:     my ($port,$iaddr);
        !          3348:     if (defined($caller) && length($caller) > 0) {
        !          3349: 	($port,$iaddr)=unpack_sockaddr_in($caller);
        !          3350:     } else {
        !          3351: 	&logthis("Unable to determine who caller was, getpeername returned nothing");
        !          3352:     }
        !          3353:     if (defined($iaddr)) {
        !          3354: 	$clientip  = inet_ntoa($iaddr);
        !          3355: 	Debug("Connected with $clientip");
        !          3356: 	$clientdns = gethostbyaddr($iaddr, AF_INET);
        !          3357: 	Debug("Connected with $clientdns by name");
        !          3358:     } else {
        !          3359: 	&logthis("Unable to determine clientip");
        !          3360: 	$clientip='Unavailable';
        !          3361:     }
        !          3362:     
        !          3363:     if ($pid) {
        !          3364:         # Parent records the child's birth and returns.
        !          3365:         sigprocmask(SIG_UNBLOCK, $sigset)
        !          3366:             or die "Can't unblock SIGINT for fork: $!\n";
        !          3367:         $children{$pid} = $clientip;
        !          3368:         &status('Started child '.$pid);
        !          3369:         return;
        !          3370:     } else {
        !          3371:         # Child can *not* return from this subroutine.
        !          3372:         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
        !          3373:         $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns 
        !          3374:                                 #don't get intercepted
        !          3375:         $SIG{USR1}= \&logstatus;
        !          3376:         $SIG{ALRM}= \&timeout;
        !          3377:         $lastlog='Forked ';
        !          3378:         $status='Forked';
1.178     foxr     3379: 
1.212   ! foxr     3380:         # unblock signals
        !          3381:         sigprocmask(SIG_UNBLOCK, $sigset)
        !          3382:             or die "Can't unblock SIGINT for fork: $!\n";
1.178     foxr     3383: 
1.212   ! foxr     3384: #        my $tmpsnum=0;            # Now global
        !          3385: #---------------------------------------------------- kerberos 5 initialization
        !          3386:         &Authen::Krb5::init_context();
        !          3387:         &Authen::Krb5::init_ets();
1.209     albertel 3388: 
1.212   ! foxr     3389: 	&status('Accepted connection');
        !          3390: # =============================================================================
        !          3391:             # do something with the connection
        !          3392: # -----------------------------------------------------------------------------
        !          3393: 	# see if we know client and 'check' for spoof IP by ineffective challenge
1.178     foxr     3394: 
1.212   ! foxr     3395: 	ReadManagerTable;	# May also be a manager!!
        !          3396: 	
        !          3397: 	my $clientrec=($hostid{$clientip}     ne undef);
        !          3398: 	my $ismanager=($managers{$clientip}    ne undef);
        !          3399: 	$clientname  = "[unknonwn]";
        !          3400: 	if($clientrec) {	# Establish client type.
        !          3401: 	    $ConnectionType = "client";
        !          3402: 	    $clientname = $hostid{$clientip};
        !          3403: 	    if($ismanager) {
        !          3404: 		$ConnectionType = "both";
        !          3405: 	    }
        !          3406: 	} else {
        !          3407: 	    $ConnectionType = "manager";
        !          3408: 	    $clientname = $managers{$clientip};
        !          3409: 	}
        !          3410: 	my $clientok;
1.178     foxr     3411: 
1.212   ! foxr     3412: 	if ($clientrec || $ismanager) {
        !          3413: 	    &status("Waiting for init from $clientip $clientname");
        !          3414: 	    &logthis('<font color="yellow">INFO: Connection, '.
        !          3415: 		     $clientip.
        !          3416: 		  " ($clientname) connection type = $ConnectionType </font>" );
        !          3417: 	    &status("Connecting $clientip  ($clientname))"); 
        !          3418: 	    my $remotereq=<$client>;
        !          3419: 	    chomp($remotereq);
        !          3420: 	    Debug("Got init: $remotereq");
        !          3421: 	    my $inikeyword = split(/:/, $remotereq);
        !          3422: 	    if ($remotereq =~ /^init/) {
        !          3423: 		&sethost("sethost:$perlvar{'lonHostID'}");
        !          3424: 		#
        !          3425: 		#  If the remote is attempting a local init... give that a try:
        !          3426: 		#
        !          3427: 		my ($i, $inittype) = split(/:/, $remotereq);
1.209     albertel 3428: 
1.212   ! foxr     3429: 		# If the connection type is ssl, but I didn't get my
        !          3430: 		# certificate files yet, then I'll drop  back to 
        !          3431: 		# insecure (if allowed).
        !          3432: 		
        !          3433: 		if($inittype eq "ssl") {
        !          3434: 		    my ($ca, $cert) = lonssl::CertificateFile;
        !          3435: 		    my $kfile       = lonssl::KeyFile;
        !          3436: 		    if((!$ca)   || 
        !          3437: 		       (!$cert) || 
        !          3438: 		       (!$kfile)) {
        !          3439: 			$inittype = ""; # This forces insecure attempt.
        !          3440: 			&logthis("<font color=\"blue\"> Certificates not "
        !          3441: 				 ."installed -- trying insecure auth</font>");
1.178     foxr     3442: 		    }
1.212   ! foxr     3443: 		    else {	# SSL certificates are in place so
        !          3444: 		    }		# Leave the inittype alone.
        !          3445: 		}
        !          3446: 
        !          3447: 		if($inittype eq "local") {
        !          3448: 		    my $key = LocalConnection($client, $remotereq);
        !          3449: 		    if($key) {
        !          3450: 			Debug("Got local key $key");
        !          3451: 			$clientok     = 1;
        !          3452: 			my $cipherkey = pack("H32", $key);
        !          3453: 			$cipher       = new IDEA($cipherkey);
        !          3454: 			print $client "ok:local\n";
        !          3455: 			&logthis('<font color="green"'
        !          3456: 				 . "Successful local authentication </font>");
        !          3457: 			$keymode = "local"
1.178     foxr     3458: 		    } else {
1.212   ! foxr     3459: 			Debug("Failed to get local key");
        !          3460: 			$clientok = 0;
        !          3461: 			shutdown($client, 3);
        !          3462: 			close $client;
1.178     foxr     3463: 		    }
1.212   ! foxr     3464: 		} elsif ($inittype eq "ssl") {
        !          3465: 		    my $key = SSLConnection($client);
        !          3466: 		    if ($key) {
        !          3467: 			$clientok = 1;
        !          3468: 			my $cipherkey = pack("H32", $key);
        !          3469: 			$cipher       = new IDEA($cipherkey);
        !          3470: 			&logthis('<font color="green">'
        !          3471: 				 ."Successfull ssl authentication with $clientname </font>");
        !          3472: 			$keymode = "ssl";
        !          3473: 	     
1.178     foxr     3474: 		    } else {
1.212   ! foxr     3475: 			$clientok = 0;
        !          3476: 			close $client;
1.178     foxr     3477: 		    }
1.212   ! foxr     3478: 	   
        !          3479: 		} else {
        !          3480: 		    my $ok = InsecureConnection($client);
        !          3481: 		    if($ok) {
        !          3482: 			$clientok = 1;
        !          3483: 			&logthis('<font color="green">'
        !          3484: 				 ."Successful insecure authentication with $clientname </font>");
        !          3485: 			print $client "ok\n";
        !          3486: 			$keymode = "insecure";
1.178     foxr     3487: 		    } else {
1.212   ! foxr     3488: 			&logthis('<font color="yellow">'
        !          3489: 				  ."Attempted insecure connection disallowed </font>");
        !          3490: 			close $client;
        !          3491: 			$clientok = 0;
1.178     foxr     3492: 			
                   3493: 		    }
                   3494: 		}
1.212   ! foxr     3495: 	    } else {
        !          3496: 		&logthis(
        !          3497: 			 "<font color='blue'>WARNING: "
        !          3498: 			 ."$clientip failed to initialize: >$remotereq< </font>");
        !          3499: 		&status('No init '.$clientip);
        !          3500: 	    }
        !          3501: 	    
        !          3502: 	} else {
        !          3503: 	    &logthis(
        !          3504: 		     "<font color='blue'>WARNING: Unknown client $clientip</font>");
        !          3505: 	    &status('Hung up on '.$clientip);
        !          3506: 	}
        !          3507:  
        !          3508: 	if ($clientok) {
        !          3509: # ---------------- New known client connecting, could mean machine online again
        !          3510: 	    
        !          3511: 	    foreach my $id (keys(%hostip)) {
        !          3512: 		if ($hostip{$id} ne $clientip ||
        !          3513: 		    $hostip{$currenthostid} eq $clientip) {
        !          3514: 		    # no need to try to do recon's to myself
        !          3515: 		    next;
        !          3516: 		}
        !          3517: 		&reconlonc("$perlvar{'lonSockDir'}/$id");
        !          3518: 	    }
        !          3519: 	    &logthis("<font color='green'>Established connection: $clientname</font>");
        !          3520: 	    &status('Will listen to '.$clientname);
        !          3521: # ------------------------------------------------------------ Process requests
        !          3522: 	    my $keep_going = 1;
        !          3523: 	    my $user_input;
        !          3524: 	    while(($user_input = get_request) && $keep_going) {
        !          3525: 		alarm(120);
        !          3526: 		Debug("Main: Got $user_input\n");
        !          3527: 		$keep_going = &process_request($user_input);
1.178     foxr     3528: 		alarm(0);
1.212   ! foxr     3529: 		&status('Listening to '.$clientname." ($keymode)");	   
1.161     foxr     3530: 	    }
1.212   ! foxr     3531: 
1.59      www      3532: # --------------------------------------------- client unknown or fishy, refuse
1.212   ! foxr     3533: 	}  else {
1.161     foxr     3534: 	    print $client "refused\n";
                   3535: 	    $client->close();
1.190     albertel 3536: 	    &logthis("<font color='blue'>WARNING: "
1.161     foxr     3537: 		     ."Rejected client $clientip, closing connection</font>");
                   3538: 	}
1.212   ! foxr     3539:     }            
1.161     foxr     3540:     
1.1       albertel 3541: # =============================================================================
1.161     foxr     3542:     
1.190     albertel 3543:     &logthis("<font color='red'>CRITICAL: "
1.161     foxr     3544: 	     ."Disconnect from $clientip ($clientname)</font>");    
                   3545:     
                   3546:     
                   3547:     # this exit is VERY important, otherwise the child will become
                   3548:     # a producer of more and more children, forking yourself into
                   3549:     # process death.
                   3550:     exit;
1.106     foxr     3551:     
1.78      foxr     3552: }
                   3553: 
                   3554: 
                   3555: #
                   3556: #   Checks to see if the input roleput request was to set
                   3557: # an author role.  If so, invokes the lchtmldir script to set
                   3558: # up a correct public_html 
                   3559: # Parameters:
                   3560: #    request   - The request sent to the rolesput subchunk.
                   3561: #                We're looking for  /domain/_au
                   3562: #    domain    - The domain in which the user is having roles doctored.
                   3563: #    user      - Name of the user for which the role is being put.
                   3564: #    authtype  - The authentication type associated with the user.
                   3565: #
                   3566: sub ManagePermissions
                   3567: {
1.192     foxr     3568: 
                   3569:     my ($request, $domain, $user, $authtype) = @_;
1.78      foxr     3570: 
                   3571:     # See if the request is of the form /$domain/_au
                   3572:     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
                   3573: 	my $execdir = $perlvar{'lonDaemons'};
                   3574: 	my $userhome= "/home/$user" ;
1.134     albertel 3575: 	&logthis("system $execdir/lchtmldir $userhome $user $authtype");
1.78      foxr     3576: 	system("$execdir/lchtmldir $userhome $user $authtype");
                   3577:     }
                   3578: }
                   3579: #
                   3580: #   GetAuthType - Determines the authorization type of a user in a domain.
                   3581: 
                   3582: #     Returns the authorization type or nouser if there is no such user.
                   3583: #
                   3584: sub GetAuthType 
                   3585: {
1.192     foxr     3586: 
                   3587:     my ($domain, $user)  = @_;
1.78      foxr     3588: 
1.79      foxr     3589:     Debug("GetAuthType( $domain, $user ) \n");
1.78      foxr     3590:     my $proname    = &propath($domain, $user); 
                   3591:     my $passwdfile = "$proname/passwd";
                   3592:     if( -e $passwdfile ) {
                   3593: 	my $pf = IO::File->new($passwdfile);
                   3594: 	my $realpassword = <$pf>;
                   3595: 	chomp($realpassword);
1.79      foxr     3596: 	Debug("Password info = $realpassword\n");
1.78      foxr     3597: 	my ($authtype, $contentpwd) = split(/:/, $realpassword);
1.79      foxr     3598: 	Debug("Authtype = $authtype, content = $contentpwd\n");
1.78      foxr     3599: 	my $availinfo = '';
1.91      albertel 3600: 	if($authtype eq 'krb4' or $authtype eq 'krb5') {
1.78      foxr     3601: 	    $availinfo = $contentpwd;
                   3602: 	}
1.79      foxr     3603: 
1.78      foxr     3604: 	return "$authtype:$availinfo";
                   3605:     }
                   3606:     else {
1.79      foxr     3607: 	Debug("Returning nouser");
1.78      foxr     3608: 	return "nouser";
                   3609:     }
1.1       albertel 3610: }
                   3611: 
1.84      albertel 3612: sub addline {
                   3613:     my ($fname,$hostid,$ip,$newline)=@_;
                   3614:     my $contents;
                   3615:     my $found=0;
                   3616:     my $expr='^'.$hostid.':'.$ip.':';
                   3617:     $expr =~ s/\./\\\./g;
1.134     albertel 3618:     my $sh;
1.84      albertel 3619:     if ($sh=IO::File->new("$fname.subscription")) {
                   3620: 	while (my $subline=<$sh>) {
                   3621: 	    if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
                   3622: 	}
                   3623: 	$sh->close();
                   3624:     }
                   3625:     $sh=IO::File->new(">$fname.subscription");
                   3626:     if ($contents) { print $sh $contents; }
                   3627:     if ($newline) { print $sh $newline; }
                   3628:     $sh->close();
                   3629:     return $found;
1.86      www      3630: }
                   3631: 
                   3632: sub getchat {
1.122     www      3633:     my ($cdom,$cname,$udom,$uname)=@_;
1.87      www      3634:     my %hash;
                   3635:     my $proname=&propath($cdom,$cname);
                   3636:     my @entries=();
1.88      albertel 3637:     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
                   3638: 	    &GDBM_READER(),0640)) {
                   3639: 	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
                   3640: 	untie %hash;
1.123     www      3641:     }
1.124     www      3642:     my @participants=();
1.134     albertel 3643:     my $cutoff=time-60;
1.123     www      3644:     if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
1.124     www      3645: 	    &GDBM_WRCREAT(),0640)) {
                   3646:         $hash{$uname.':'.$udom}=time;
1.123     www      3647:         foreach (sort keys %hash) {
                   3648: 	    if ($hash{$_}>$cutoff) {
1.124     www      3649: 		$participants[$#participants+1]='active_participant:'.$_;
1.123     www      3650:             }
                   3651:         }
                   3652:         untie %hash;
1.86      www      3653:     }
1.124     www      3654:     return (@participants,@entries);
1.86      www      3655: }
                   3656: 
                   3657: sub chatadd {
1.88      albertel 3658:     my ($cdom,$cname,$newchat)=@_;
                   3659:     my %hash;
                   3660:     my $proname=&propath($cdom,$cname);
                   3661:     my @entries=();
1.142     www      3662:     my $time=time;
1.88      albertel 3663:     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
                   3664: 	    &GDBM_WRCREAT(),0640)) {
                   3665: 	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
                   3666: 	my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
                   3667: 	my ($thentime,$idnum)=split(/\_/,$lastid);
                   3668: 	my $newid=$time.'_000000';
                   3669: 	if ($thentime==$time) {
                   3670: 	    $idnum=~s/^0+//;
                   3671: 	    $idnum++;
                   3672: 	    $idnum=substr('000000'.$idnum,-6,6);
                   3673: 	    $newid=$time.'_'.$idnum;
                   3674: 	}
                   3675: 	$hash{$newid}=$newchat;
                   3676: 	my $expired=$time-3600;
                   3677: 	foreach (keys %hash) {
                   3678: 	    my ($thistime)=($_=~/(\d+)\_/);
                   3679: 	    if ($thistime<$expired) {
1.89      www      3680: 		delete $hash{$_};
1.88      albertel 3681: 	    }
                   3682: 	}
                   3683: 	untie %hash;
1.142     www      3684:     }
                   3685:     {
                   3686: 	my $hfh;
                   3687: 	if ($hfh=IO::File->new(">>$proname/chatroom.log")) { 
                   3688: 	    print $hfh "$time:".&unescape($newchat)."\n";
                   3689: 	}
1.86      www      3690:     }
1.84      albertel 3691: }
                   3692: 
                   3693: sub unsub {
                   3694:     my ($fname,$clientip)=@_;
                   3695:     my $result;
1.188     foxr     3696:     my $unsubs = 0;		# Number of successful unsubscribes:
                   3697: 
                   3698: 
                   3699:     # An old way subscriptions were handled was to have a 
                   3700:     # subscription marker file:
                   3701: 
                   3702:     Debug("Attempting unlink of $fname.$clientname");
1.161     foxr     3703:     if (unlink("$fname.$clientname")) {
1.188     foxr     3704: 	$unsubs++;		# Successful unsub via marker file.
                   3705:     } 
                   3706: 
                   3707:     # The more modern way to do it is to have a subscription list
                   3708:     # file:
                   3709: 
1.84      albertel 3710:     if (-e "$fname.subscription") {
1.161     foxr     3711: 	my $found=&addline($fname,$clientname,$clientip,'');
1.188     foxr     3712: 	if ($found) { 
                   3713: 	    $unsubs++;
                   3714: 	}
                   3715:     } 
                   3716: 
                   3717:     #  If either or both of these mechanisms succeeded in unsubscribing a 
                   3718:     #  resource we can return ok:
                   3719: 
                   3720:     if($unsubs) {
                   3721: 	$result = "ok\n";
1.84      albertel 3722:     } else {
1.188     foxr     3723: 	$result = "not_subscribed\n";
1.84      albertel 3724:     }
1.188     foxr     3725: 
1.84      albertel 3726:     return $result;
                   3727: }
                   3728: 
1.101     www      3729: sub currentversion {
                   3730:     my $fname=shift;
                   3731:     my $version=-1;
                   3732:     my $ulsdir='';
                   3733:     if ($fname=~/^(.+)\/[^\/]+$/) {
                   3734:        $ulsdir=$1;
                   3735:     }
1.114     albertel 3736:     my ($fnamere1,$fnamere2);
                   3737:     # remove version if already specified
1.101     www      3738:     $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
1.114     albertel 3739:     # get the bits that go before and after the version number
                   3740:     if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
                   3741: 	$fnamere1=$1;
                   3742: 	$fnamere2='.'.$2;
                   3743:     }
1.101     www      3744:     if (-e $fname) { $version=1; }
                   3745:     if (-e $ulsdir) {
1.134     albertel 3746: 	if(-d $ulsdir) {
                   3747: 	    if (opendir(LSDIR,$ulsdir)) {
                   3748: 		my $ulsfn;
                   3749: 		while ($ulsfn=readdir(LSDIR)) {
1.101     www      3750: # see if this is a regular file (ignore links produced earlier)
1.134     albertel 3751: 		    my $thisfile=$ulsdir.'/'.$ulsfn;
                   3752: 		    unless (-l $thisfile) {
1.160     www      3753: 			if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) {
1.134     albertel 3754: 			    if ($1>$version) { $version=$1; }
                   3755: 			}
                   3756: 		    }
                   3757: 		}
                   3758: 		closedir(LSDIR);
                   3759: 		$version++;
                   3760: 	    }
                   3761: 	}
                   3762:     }
                   3763:     return $version;
1.101     www      3764: }
                   3765: 
                   3766: sub thisversion {
                   3767:     my $fname=shift;
                   3768:     my $version=-1;
                   3769:     if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
                   3770: 	$version=$1;
                   3771:     }
                   3772:     return $version;
                   3773: }
                   3774: 
1.84      albertel 3775: sub subscribe {
                   3776:     my ($userinput,$clientip)=@_;
                   3777:     my $result;
                   3778:     my ($cmd,$fname)=split(/:/,$userinput);
                   3779:     my $ownership=&ishome($fname);
                   3780:     if ($ownership eq 'owner') {
1.101     www      3781: # explitly asking for the current version?
                   3782:         unless (-e $fname) {
                   3783:             my $currentversion=&currentversion($fname);
                   3784: 	    if (&thisversion($fname)==$currentversion) {
                   3785:                 if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
                   3786: 		    my $root=$1;
                   3787:                     my $extension=$2;
                   3788:                     symlink($root.'.'.$extension,
                   3789:                             $root.'.'.$currentversion.'.'.$extension);
1.102     www      3790:                     unless ($extension=~/\.meta$/) {
                   3791:                        symlink($root.'.'.$extension.'.meta',
                   3792:                             $root.'.'.$currentversion.'.'.$extension.'.meta');
                   3793: 		    }
1.101     www      3794:                 }
                   3795:             }
                   3796:         }
1.84      albertel 3797: 	if (-e $fname) {
                   3798: 	    if (-d $fname) {
                   3799: 		$result="directory\n";
                   3800: 	    } else {
1.161     foxr     3801: 		if (-e "$fname.$clientname") {&unsub($fname,$clientip);}
1.134     albertel 3802: 		my $now=time;
1.161     foxr     3803: 		my $found=&addline($fname,$clientname,$clientip,
                   3804: 				   "$clientname:$clientip:$now\n");
1.84      albertel 3805: 		if ($found) { $result="$fname\n"; }
                   3806: 		# if they were subscribed to only meta data, delete that
                   3807:                 # subscription, when you subscribe to a file you also get
                   3808:                 # the metadata
                   3809: 		unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
                   3810: 		$fname=~s/\/home\/httpd\/html\/res/raw/;
                   3811: 		$fname="http://$thisserver/".$fname;
                   3812: 		$result="$fname\n";
                   3813: 	    }
                   3814: 	} else {
                   3815: 	    $result="not_found\n";
                   3816: 	}
                   3817:     } else {
                   3818: 	$result="rejected\n";
                   3819:     }
                   3820:     return $result;
                   3821: }
1.91      albertel 3822: 
                   3823: sub make_passwd_file {
1.98      foxr     3824:     my ($uname, $umode,$npass,$passfilename)=@_;
1.91      albertel 3825:     my $result="ok\n";
                   3826:     if ($umode eq 'krb4' or $umode eq 'krb5') {
                   3827: 	{
                   3828: 	    my $pf = IO::File->new(">$passfilename");
                   3829: 	    print $pf "$umode:$npass\n";
                   3830: 	}
                   3831:     } elsif ($umode eq 'internal') {
                   3832: 	my $salt=time;
                   3833: 	$salt=substr($salt,6,2);
                   3834: 	my $ncpass=crypt($npass,$salt);
                   3835: 	{
                   3836: 	    &Debug("Creating internal auth");
                   3837: 	    my $pf = IO::File->new(">$passfilename");
                   3838: 	    print $pf "internal:$ncpass\n"; 
                   3839: 	}
                   3840:     } elsif ($umode eq 'localauth') {
                   3841: 	{
                   3842: 	    my $pf = IO::File->new(">$passfilename");
                   3843: 	    print $pf "localauth:$npass\n";
                   3844: 	}
                   3845:     } elsif ($umode eq 'unix') {
                   3846: 	{
1.186     foxr     3847: 	    #
                   3848: 	    #  Don't allow the creation of privileged accounts!!! that would
                   3849: 	    #  be real bad!!!
                   3850: 	    #
                   3851: 	    my $uid = getpwnam($uname);
                   3852: 	    if((defined $uid) && ($uid == 0)) {
                   3853: 		&logthis(">>>Attempted to create privilged account blocked");
                   3854: 		return "no_priv_account_error\n";
                   3855: 	    }
                   3856: 
1.91      albertel 3857: 	    my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
                   3858: 	    {
                   3859: 		&Debug("Executing external: ".$execpath);
1.98      foxr     3860: 		&Debug("user  = ".$uname.", Password =". $npass);
1.132     matthew  3861: 		my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
1.91      albertel 3862: 		print $se "$uname\n";
                   3863: 		print $se "$npass\n";
                   3864: 		print $se "$npass\n";
1.97      foxr     3865: 	    }
                   3866: 	    my $useraddok = $?;
                   3867: 	    if($useraddok > 0) {
                   3868: 		&logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
1.91      albertel 3869: 	    }
                   3870: 	    my $pf = IO::File->new(">$passfilename");
                   3871: 	    print $pf "unix:\n";
                   3872: 	}
                   3873:     } elsif ($umode eq 'none') {
                   3874: 	{
                   3875: 	    my $pf = IO::File->new(">$passfilename");
                   3876: 	    print $pf "none:\n";
                   3877: 	}
                   3878:     } else {
                   3879: 	$result="auth_mode_error\n";
                   3880:     }
                   3881:     return $result;
1.121     albertel 3882: }
                   3883: 
                   3884: sub sethost {
                   3885:     my ($remotereq) = @_;
                   3886:     my (undef,$hostid)=split(/:/,$remotereq);
                   3887:     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
                   3888:     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
1.200     matthew  3889: 	$currenthostid  =$hostid;
1.121     albertel 3890: 	$currentdomainid=$hostdom{$hostid};
                   3891: 	&logthis("Setting hostid to $hostid, and domain to $currentdomainid");
                   3892:     } else {
                   3893: 	&logthis("Requested host id $hostid not an alias of ".
                   3894: 		 $perlvar{'lonHostID'}." refusing connection");
                   3895: 	return 'unable_to_set';
                   3896:     }
                   3897:     return 'ok';
                   3898: }
                   3899: 
                   3900: sub version {
                   3901:     my ($userinput)=@_;
                   3902:     $remoteVERSION=(split(/:/,$userinput))[1];
                   3903:     return "version:$VERSION";
1.127     albertel 3904: }
1.178     foxr     3905: 
1.128     albertel 3906: #There is a copy of this in lonnet.pm
1.127     albertel 3907: sub userload {
                   3908:     my $numusers=0;
                   3909:     {
                   3910: 	opendir(LONIDS,$perlvar{'lonIDsDir'});
                   3911: 	my $filename;
                   3912: 	my $curtime=time;
                   3913: 	while ($filename=readdir(LONIDS)) {
                   3914: 	    if ($filename eq '.' || $filename eq '..') {next;}
1.138     albertel 3915: 	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
1.159     albertel 3916: 	    if ($curtime-$mtime < 1800) { $numusers++; }
1.127     albertel 3917: 	}
                   3918: 	closedir(LONIDS);
                   3919:     }
                   3920:     my $userloadpercent=0;
                   3921:     my $maxuserload=$perlvar{'lonUserLoadLim'};
                   3922:     if ($maxuserload) {
1.129     albertel 3923: 	$userloadpercent=100*$numusers/$maxuserload;
1.127     albertel 3924:     }
1.130     albertel 3925:     $userloadpercent=sprintf("%.2f",$userloadpercent);
1.127     albertel 3926:     return $userloadpercent;
1.91      albertel 3927: }
                   3928: 
1.205     raeburn  3929: # Routines for serializing arrays and hashes (copies from lonnet)
                   3930: 
                   3931: sub array2str {
                   3932:   my (@array) = @_;
                   3933:   my $result=&arrayref2str(\@array);
                   3934:   $result=~s/^__ARRAY_REF__//;
                   3935:   $result=~s/__END_ARRAY_REF__$//;
                   3936:   return $result;
                   3937: }
                   3938:                                                                                  
                   3939: sub arrayref2str {
                   3940:   my ($arrayref) = @_;
                   3941:   my $result='__ARRAY_REF__';
                   3942:   foreach my $elem (@$arrayref) {
                   3943:     if(ref($elem) eq 'ARRAY') {
                   3944:       $result.=&arrayref2str($elem).'&';
                   3945:     } elsif(ref($elem) eq 'HASH') {
                   3946:       $result.=&hashref2str($elem).'&';
                   3947:     } elsif(ref($elem)) {
                   3948:       #print("Got a ref of ".(ref($elem))." skipping.");
                   3949:     } else {
                   3950:       $result.=&escape($elem).'&';
                   3951:     }
                   3952:   }
                   3953:   $result=~s/\&$//;
                   3954:   $result .= '__END_ARRAY_REF__';
                   3955:   return $result;
                   3956: }
                   3957:                                                                                  
                   3958: sub hash2str {
                   3959:   my (%hash) = @_;
                   3960:   my $result=&hashref2str(\%hash);
                   3961:   $result=~s/^__HASH_REF__//;
                   3962:   $result=~s/__END_HASH_REF__$//;
                   3963:   return $result;
                   3964: }
                   3965:                                                                                  
                   3966: sub hashref2str {
                   3967:   my ($hashref)=@_;
                   3968:   my $result='__HASH_REF__';
                   3969:   foreach (sort(keys(%$hashref))) {
                   3970:     if (ref($_) eq 'ARRAY') {
                   3971:       $result.=&arrayref2str($_).'=';
                   3972:     } elsif (ref($_) eq 'HASH') {
                   3973:       $result.=&hashref2str($_).'=';
                   3974:     } elsif (ref($_)) {
                   3975:       $result.='=';
                   3976:       #print("Got a ref of ".(ref($_))." skipping.");
                   3977:     } else {
                   3978:         if ($_) {$result.=&escape($_).'=';} else { last; }
                   3979:     }
                   3980: 
                   3981:     if(ref($hashref->{$_}) eq 'ARRAY') {
                   3982:       $result.=&arrayref2str($hashref->{$_}).'&';
                   3983:     } elsif(ref($hashref->{$_}) eq 'HASH') {
                   3984:       $result.=&hashref2str($hashref->{$_}).'&';
                   3985:     } elsif(ref($hashref->{$_})) {
                   3986:        $result.='&';
                   3987:       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
                   3988:     } else {
                   3989:       $result.=&escape($hashref->{$_}).'&';
                   3990:     }
                   3991:   }
                   3992:   $result=~s/\&$//;
                   3993:   $result .= '__END_HASH_REF__';
                   3994:   return $result;
                   3995: }
1.200     matthew  3996: 
1.61      harris41 3997: # ----------------------------------- POD (plain old documentation, CPAN style)
                   3998: 
                   3999: =head1 NAME
                   4000: 
                   4001: lond - "LON Daemon" Server (port "LOND" 5663)
                   4002: 
                   4003: =head1 SYNOPSIS
                   4004: 
1.74      harris41 4005: Usage: B<lond>
                   4006: 
                   4007: Should only be run as user=www.  This is a command-line script which
                   4008: is invoked by B<loncron>.  There is no expectation that a typical user
                   4009: will manually start B<lond> from the command-line.  (In other words,
                   4010: DO NOT START B<lond> YOURSELF.)
1.61      harris41 4011: 
                   4012: =head1 DESCRIPTION
                   4013: 
1.74      harris41 4014: There are two characteristics associated with the running of B<lond>,
                   4015: PROCESS MANAGEMENT (starting, stopping, handling child processes)
                   4016: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
                   4017: subscriptions, etc).  These are described in two large
                   4018: sections below.
                   4019: 
                   4020: B<PROCESS MANAGEMENT>
                   4021: 
1.61      harris41 4022: Preforker - server who forks first. Runs as a daemon. HUPs.
                   4023: Uses IDEA encryption
                   4024: 
1.74      harris41 4025: B<lond> forks off children processes that correspond to the other servers
                   4026: in the network.  Management of these processes can be done at the
                   4027: parent process level or the child process level.
                   4028: 
                   4029: B<logs/lond.log> is the location of log messages.
                   4030: 
                   4031: The process management is now explained in terms of linux shell commands,
                   4032: subroutines internal to this code, and signal assignments:
                   4033: 
                   4034: =over 4
                   4035: 
                   4036: =item *
                   4037: 
                   4038: PID is stored in B<logs/lond.pid>
                   4039: 
                   4040: This is the process id number of the parent B<lond> process.
                   4041: 
                   4042: =item *
                   4043: 
                   4044: SIGTERM and SIGINT
                   4045: 
                   4046: Parent signal assignment:
                   4047:  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
                   4048: 
                   4049: Child signal assignment:
                   4050:  $SIG{INT}  = 'DEFAULT'; (and SIGTERM is DEFAULT also)
                   4051: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
                   4052:  to restart a new child.)
                   4053: 
                   4054: Command-line invocations:
                   4055:  B<kill> B<-s> SIGTERM I<PID>
                   4056:  B<kill> B<-s> SIGINT I<PID>
                   4057: 
                   4058: Subroutine B<HUNTSMAN>:
                   4059:  This is only invoked for the B<lond> parent I<PID>.
                   4060: This kills all the children, and then the parent.
                   4061: The B<lonc.pid> file is cleared.
                   4062: 
                   4063: =item *
                   4064: 
                   4065: SIGHUP
                   4066: 
                   4067: Current bug:
                   4068:  This signal can only be processed the first time
                   4069: on the parent process.  Subsequent SIGHUP signals
                   4070: have no effect.
                   4071: 
                   4072: Parent signal assignment:
                   4073:  $SIG{HUP}  = \&HUPSMAN;
                   4074: 
                   4075: Child signal assignment:
                   4076:  none (nothing happens)
                   4077: 
                   4078: Command-line invocations:
                   4079:  B<kill> B<-s> SIGHUP I<PID>
                   4080: 
                   4081: Subroutine B<HUPSMAN>:
                   4082:  This is only invoked for the B<lond> parent I<PID>,
                   4083: This kills all the children, and then the parent.
                   4084: The B<lond.pid> file is cleared.
                   4085: 
                   4086: =item *
                   4087: 
                   4088: SIGUSR1
                   4089: 
                   4090: Parent signal assignment:
                   4091:  $SIG{USR1} = \&USRMAN;
                   4092: 
                   4093: Child signal assignment:
                   4094:  $SIG{USR1}= \&logstatus;
                   4095: 
                   4096: Command-line invocations:
                   4097:  B<kill> B<-s> SIGUSR1 I<PID>
                   4098: 
                   4099: Subroutine B<USRMAN>:
                   4100:  When invoked for the B<lond> parent I<PID>,
                   4101: SIGUSR1 is sent to all the children, and the status of
                   4102: each connection is logged.
1.144     foxr     4103: 
                   4104: =item *
                   4105: 
                   4106: SIGUSR2
                   4107: 
                   4108: Parent Signal assignment:
                   4109:     $SIG{USR2} = \&UpdateHosts
                   4110: 
                   4111: Child signal assignment:
                   4112:     NONE
                   4113: 
1.74      harris41 4114: 
                   4115: =item *
                   4116: 
                   4117: SIGCHLD
                   4118: 
                   4119: Parent signal assignment:
                   4120:  $SIG{CHLD} = \&REAPER;
                   4121: 
                   4122: Child signal assignment:
                   4123:  none
                   4124: 
                   4125: Command-line invocations:
                   4126:  B<kill> B<-s> SIGCHLD I<PID>
                   4127: 
                   4128: Subroutine B<REAPER>:
                   4129:  This is only invoked for the B<lond> parent I<PID>.
                   4130: Information pertaining to the child is removed.
                   4131: The socket port is cleaned up.
                   4132: 
                   4133: =back
                   4134: 
                   4135: B<SERVER-SIDE ACTIVITIES>
                   4136: 
                   4137: Server-side information can be accepted in an encrypted or non-encrypted
                   4138: method.
                   4139: 
                   4140: =over 4
                   4141: 
                   4142: =item ping
                   4143: 
                   4144: Query a client in the hosts.tab table; "Are you there?"
                   4145: 
                   4146: =item pong
                   4147: 
                   4148: Respond to a ping query.
                   4149: 
                   4150: =item ekey
                   4151: 
                   4152: Read in encrypted key, make cipher.  Respond with a buildkey.
                   4153: 
                   4154: =item load
                   4155: 
                   4156: Respond with CPU load based on a computation upon /proc/loadavg.
                   4157: 
                   4158: =item currentauth
                   4159: 
                   4160: Reply with current authentication information (only over an
                   4161: encrypted channel).
                   4162: 
                   4163: =item auth
                   4164: 
                   4165: Only over an encrypted channel, reply as to whether a user's
                   4166: authentication information can be validated.
                   4167: 
                   4168: =item passwd
                   4169: 
                   4170: Allow for a password to be set.
                   4171: 
                   4172: =item makeuser
                   4173: 
                   4174: Make a user.
                   4175: 
                   4176: =item passwd
                   4177: 
                   4178: Allow for authentication mechanism and password to be changed.
                   4179: 
                   4180: =item home
1.61      harris41 4181: 
1.74      harris41 4182: Respond to a question "are you the home for a given user?"
                   4183: 
                   4184: =item update
                   4185: 
                   4186: Update contents of a subscribed resource.
                   4187: 
                   4188: =item unsubscribe
                   4189: 
                   4190: The server is unsubscribing from a resource.
                   4191: 
                   4192: =item subscribe
                   4193: 
                   4194: The server is subscribing to a resource.
                   4195: 
                   4196: =item log
                   4197: 
                   4198: Place in B<logs/lond.log>
                   4199: 
                   4200: =item put
                   4201: 
                   4202: stores hash in namespace
                   4203: 
                   4204: =item rolesput
                   4205: 
                   4206: put a role into a user's environment
                   4207: 
                   4208: =item get
                   4209: 
                   4210: returns hash with keys from array
                   4211: reference filled in from namespace
                   4212: 
                   4213: =item eget
                   4214: 
                   4215: returns hash with keys from array
                   4216: reference filled in from namesp (encrypts the return communication)
                   4217: 
                   4218: =item rolesget
                   4219: 
                   4220: get a role from a user's environment
                   4221: 
                   4222: =item del
                   4223: 
                   4224: deletes keys out of array from namespace
                   4225: 
                   4226: =item keys
                   4227: 
                   4228: returns namespace keys
                   4229: 
                   4230: =item dump
                   4231: 
                   4232: dumps the complete (or key matching regexp) namespace into a hash
                   4233: 
                   4234: =item store
                   4235: 
                   4236: stores hash permanently
                   4237: for this url; hashref needs to be given and should be a \%hashname; the
                   4238: remaining args aren't required and if they aren't passed or are '' they will
                   4239: be derived from the ENV
                   4240: 
                   4241: =item restore
                   4242: 
                   4243: returns a hash for a given url
                   4244: 
                   4245: =item querysend
                   4246: 
                   4247: Tells client about the lonsql process that has been launched in response
                   4248: to a sent query.
                   4249: 
                   4250: =item queryreply
                   4251: 
                   4252: Accept information from lonsql and make appropriate storage in temporary
                   4253: file space.
                   4254: 
                   4255: =item idput
                   4256: 
                   4257: Defines usernames as corresponding to IDs.  (These "IDs" are unique identifiers
                   4258: for each student, defined perhaps by the institutional Registrar.)
                   4259: 
                   4260: =item idget
                   4261: 
                   4262: Returns usernames corresponding to IDs.  (These "IDs" are unique identifiers
                   4263: for each student, defined perhaps by the institutional Registrar.)
                   4264: 
                   4265: =item tmpput
                   4266: 
                   4267: Accept and store information in temporary space.
                   4268: 
                   4269: =item tmpget
                   4270: 
                   4271: Send along temporarily stored information.
                   4272: 
                   4273: =item ls
                   4274: 
                   4275: List part of a user's directory.
                   4276: 
1.135     foxr     4277: =item pushtable
                   4278: 
                   4279: Pushes a file in /home/httpd/lonTab directory.  Currently limited to:
                   4280: hosts.tab and domain.tab. The old file is copied to  *.tab.backup but
                   4281: must be restored manually in case of a problem with the new table file.
                   4282: pushtable requires that the request be encrypted and validated via
                   4283: ValidateManager.  The form of the command is:
                   4284: enc:pushtable tablename <tablecontents> \n
                   4285: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a 
                   4286: cleartext newline.
                   4287: 
1.74      harris41 4288: =item Hanging up (exit or init)
                   4289: 
                   4290: What to do when a client tells the server that they (the client)
                   4291: are leaving the network.
                   4292: 
                   4293: =item unknown command
                   4294: 
                   4295: If B<lond> is sent an unknown command (not in the list above),
                   4296: it replys to the client "unknown_cmd".
1.135     foxr     4297: 
1.74      harris41 4298: 
                   4299: =item UNKNOWN CLIENT
                   4300: 
                   4301: If the anti-spoofing algorithm cannot verify the client,
                   4302: the client is rejected (with a "refused" message sent
                   4303: to the client, and the connection is closed.
                   4304: 
                   4305: =back
1.61      harris41 4306: 
                   4307: =head1 PREREQUISITES
                   4308: 
                   4309: IO::Socket
                   4310: IO::File
                   4311: Apache::File
                   4312: Symbol
                   4313: POSIX
                   4314: Crypt::IDEA
                   4315: LWP::UserAgent()
                   4316: GDBM_File
                   4317: Authen::Krb4
1.91      albertel 4318: Authen::Krb5
1.61      harris41 4319: 
                   4320: =head1 COREQUISITES
                   4321: 
                   4322: =head1 OSNAMES
                   4323: 
                   4324: linux
                   4325: 
                   4326: =head1 SCRIPT CATEGORIES
                   4327: 
                   4328: Server/Process
                   4329: 
                   4330: =cut

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>