File:  [LON-CAPA] / loncom / lond
Revision 1.146: download - view: text, annotated - select for diffs
Tue Sep 16 10:28:14 2003 UTC (21 years, 1 month ago) by foxr
Branches: MAIN
CVS tags: HEAD
ReinitProcess - decode the process selector and produce the associated pid
filename.  Note: While it is possible to test that valid process selectors are
handled properly I am not able to test that invalid process selectors produce
the appropriate error as lonManage also blocks the use of invalid process selectors.

    1: #!/usr/bin/perl
    2: # The LearningOnline Network
    3: # lond "LON Daemon" Server (port "LOND" 5663)
    4: #
    5: # $Id: lond,v 1.146 2003/09/16 10:28:14 foxr Exp $
    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
   13: # the Free Software Foundation; either version 2 of the License, or
   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
   23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   24: #
   25: # /home/httpd/html/adm/gpl.txt
   26: #
   27: # http://www.lon-capa.org/
   28: #
   29: # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,
   30: # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,
   31: # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
   32: # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
   33: # 03/07,05/31 Gerd Kortemeyer
   34: # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
   35: # 12/05,12/13,12/29 Gerd Kortemeyer
   36: # YEAR=2001
   37: # 02/12 Gerd Kortemeyer
   38: # 03/24 Gerd Kortemeyer
   39: # 05/11,05/28,08/30 Gerd Kortemeyer
   40: # 11/26,11/27 Gerd Kortemeyer
   41: # 12/22 Gerd Kortemeyer
   42: # YEAR=2002
   43: # 01/20/02,02/05 Gerd Kortemeyer
   44: # 02/05 Guy Albertelli
   45: # 02/12 Gerd Kortemeyer
   46: # 02/19 Matthew Hall
   47: # 02/25 Gerd Kortemeyer
   48: # 01/xx/2003 Ron Fox.. Remove preforking.  This makes the general daemon
   49: #      logic simpler (and there were problems maintaining the preforked
   50: #      population).  Since the time averaged connection rate is close to zero
   51: #      because lonc's purpose is to maintain near continuous connnections,
   52: #      preforking is not really needed.
   53: # 08/xx/2003 Ron Fox:  Add management requests.  Management requests
   54: #      will be validated via a call to ValidateManager. At present, this
   55: #      is done by simple host verification.  In the future we can modify
   56: #      this function to do a certificate check.
   57: #      Management functions supported include:
   58: #       - pushing /home/httpd/lonTabs/hosts.tab
   59: #       - pushing /home/httpd/lonTabs/domain.tab
   60: # 09/08/2003 Ron Fox:  Told lond to take care of change logging so we
   61: #      don't have to remember it:
   62: # $Log: lond,v $
   63: # Revision 1.146  2003/09/16 10:28:14  foxr
   64: # ReinitProcess - decode the process selector and produce the associated pid
   65: # filename.  Note: While it is possible to test that valid process selectors are
   66: # handled properly I am not able to test that invalid process selectors produce
   67: # the appropriate error as lonManage also blocks the use of invalid process selectors.
   68: #
   69: # Revision 1.145  2003/09/16 10:13:20  foxr
   70: # Added ReinitProcess function to oversee the parsing and processing of the
   71: # reinit:<process> client request.
   72: #
   73: # Revision 1.144  2003/09/16 09:47:01  foxr
   74: # Added skeletal support for SIGUSR2 (update hosts.tab)
   75: #
   76: # Revision 1.143  2003/09/15 10:03:52  foxr
   77: # Completed and tested code for pushfile.
   78: #
   79: # Revision 1.142  2003/09/09 20:47:46  www
   80: # Permanently store chatroom entries in chatroom.log
   81: #
   82: # Revision 1.141  2003/09/08 10:32:07  foxr
   83: # Added PushFile sub This sub oversees the push of a new configuration table file
   84: # Currently supported files are:
   85: # - hosts.tab   (transaction pushfile:hosts:contents)
   86: # - domain.tab  (transaction pushfile:domain:contents)
   87: #
   88: 
   89: 
   90: use strict;
   91: use lib '/home/httpd/lib/perl/';
   92: use LONCAPA::Configuration;
   93: 
   94: use IO::Socket;
   95: use IO::File;
   96: #use Apache::File;
   97: use Symbol;
   98: use POSIX;
   99: use Crypt::IDEA;
  100: use LWP::UserAgent();
  101: use GDBM_File;
  102: use Authen::Krb4;
  103: use Authen::Krb5;
  104: use lib '/home/httpd/lib/perl/';
  105: use localauth;
  106: use File::Copy;
  107: 
  108: my $DEBUG = 0;		       # Non zero to enable debug log entries.
  109: 
  110: my $status='';
  111: my $lastlog='';
  112: 
  113: my $VERSION='$Revision: 1.146 $'; #' stupid emacs
  114: my $remoteVERSION;
  115: my $currenthostid;
  116: my $currentdomainid;
  117: 
  118: my $client;
  119: my $clientip;
  120: 
  121: my $server;
  122: my $thisserver;
  123: 
  124: my %hostid;
  125: my %hostdom;
  126: my %hostip;
  127: my %perlvar;			# Will have the apache conf defined perl vars.
  128: 
  129: #
  130: #  The array below are password error strings."
  131: #
  132: my $lastpwderror    = 13;		# Largest error number from lcpasswd.
  133: my @passwderrors = ("ok",
  134: 		   "lcpasswd must be run as user 'www'",
  135: 		   "lcpasswd got incorrect number of arguments",
  136: 		   "lcpasswd did not get the right nubmer of input text lines",
  137: 		   "lcpasswd too many simultaneous pwd changes in progress",
  138: 		   "lcpasswd User does not exist.",
  139: 		   "lcpasswd Incorrect current passwd",
  140: 		   "lcpasswd Unable to su to root.",
  141: 		   "lcpasswd Cannot set new passwd.",
  142: 		   "lcpasswd Username has invalid characters",
  143: 		   "lcpasswd Invalid characters in password",
  144: 		    "11", "12",
  145: 		    "lcpasswd Password mismatch");
  146: 
  147: 
  148: #  The array below are lcuseradd error strings.:
  149: 
  150: my $lastadderror = 13;
  151: my @adderrors    = ("ok",
  152: 		    "User ID mismatch, lcuseradd must run as user www",
  153: 		    "lcuseradd Incorrect number of command line parameters must be 3",
  154: 		    "lcuseradd Incorrect number of stdinput lines, must be 3",
  155: 		    "lcuseradd Too many other simultaneous pwd changes in progress",
  156: 		    "lcuseradd User does not exist",
  157: 		    "lcuseradd Unabel to mak ewww member of users's group",
  158: 		    "lcuseradd Unable to su to root",
  159: 		    "lcuseradd Unable to set password",
  160: 		    "lcuseradd Usrname has invbalid charcters",
  161: 		    "lcuseradd Password has an invalid character",
  162: 		    "lcuseradd User already exists",
  163: 		    "lcuseradd Could not add user.",
  164: 		    "lcuseradd Password mismatch");
  165: 
  166: 
  167: #
  168: #   GetCertificate: Given a transaction that requires a certificate,
  169: #   this function will extract the certificate from the transaction
  170: #   request.  Note that at this point, the only concept of a certificate
  171: #   is the hostname to which we are connected.
  172: #
  173: #   Parameter:
  174: #      request   - The request sent by our client (this parameterization may
  175: #                  need to change when we really use a certificate granting
  176: #                  authority.
  177: #
  178: sub GetCertificate {
  179:     my $request = shift;
  180: 
  181:     return $clientip;
  182: }
  183: 
  184: 
  185: #
  186: #  ValidManager: Determines if a given certificate represents a valid manager.
  187: #                in this primitive implementation, the 'certificate' is
  188: #                just the connecting loncapa client name.  This is checked
  189: #                against a valid client list in the configuration.
  190: #
  191: #                  
  192: sub ValidManager {
  193:     my $certificate = shift; 
  194: 
  195:     my $hostentry   = $hostid{$certificate};
  196:     if ($hostentry ne undef) {
  197: 	&logthis('<font color="yellow">Authenticating manager'.
  198: 		 " $hostentry</font>");
  199: 	return 1;
  200:     } else {
  201: 	&logthis('<font color="red"> Failed manager authentication '.
  202: 		 "$certificate </font>");
  203:     }
  204: }
  205: #
  206: #  CopyFile:  Called as part of the process of installing a 
  207: #             new configuration file.  This function copies an existing
  208: #             file to a backup file.
  209: # Parameters:
  210: #     oldfile  - Name of the file to backup.
  211: #     newfile  - Name of the backup file.
  212: # Return:
  213: #     0   - Failure (errno has failure reason).
  214: #     1   - Success.
  215: #
  216: sub CopyFile {
  217:     my $oldfile = shift;
  218:     my $newfile = shift;
  219: 
  220:     #  The file must exist:
  221: 
  222:     if(-e $oldfile) {
  223: 
  224: 	 # Read the old file.
  225: 
  226: 	my $oldfh = IO::File->new("< $oldfile");
  227: 	if(!$oldfh) {
  228: 	    return 0;
  229: 	}
  230: 	my @contents = <$oldfh>;  # Suck in the entire file.
  231: 
  232: 	# write the backup file:
  233: 
  234: 	my $newfh = IO::File->new("> $newfile");
  235: 	if(!(defined $newfh)){
  236: 	    return 0;
  237: 	}
  238: 	my $lines = scalar @contents;
  239: 	for (my $i =0; $i < $lines; $i++) {
  240: 	    print $newfh ($contents[$i]);
  241: 	}
  242: 
  243: 	$oldfh->close;
  244: 	$newfh->close;
  245: 
  246: 	chmod(0660, $newfile);
  247: 
  248: 	return 1;
  249: 	    
  250:     } else {
  251: 	return 0;
  252:     }
  253: }
  254: 
  255: #
  256: #   InstallFile: Called to install an administrative file:
  257: #       - The file is created with <name>.tmp
  258: #       - The <name>.tmp file is then mv'd to <name>
  259: #   This lugubrious procedure is done to ensure that we are never without
  260: #   a valid, even if dated, version of the file regardless of who crashes
  261: #   and when the crash occurs.
  262: #
  263: #  Parameters:
  264: #       Name of the file
  265: #       File Contents.
  266: #  Return:
  267: #      nonzero - success.
  268: #      0       - failure and $! has an errno.
  269: #
  270: sub InstallFile {
  271:     my $Filename = shift;
  272:     my $Contents = shift;
  273:     my $TempFile = $Filename.".tmp";
  274: 
  275:     #  Open the file for write:
  276: 
  277:     my $fh = IO::File->new("> $TempFile"); # Write to temp.
  278:     if(!(defined $fh)) {
  279: 	&logthis('<font color="red"> Unable to create '.$TempFile."</font>");
  280: 	return 0;
  281:     }
  282:     #  write the contents of the file:
  283: 
  284:     print $fh ($Contents); 
  285:     $fh->close;			# In case we ever have a filesystem w. locking
  286: 
  287:     chmod(0660, $TempFile);
  288: 
  289:     # Now we can move install the file in position.
  290:     
  291:     move($TempFile, $Filename);
  292: 
  293:     return 1;
  294: }
  295: 
  296: #
  297: #   PushFile:  Called to do an administrative push of a file.
  298: #              - Ensure the file being pushed is one we support.
  299: #              - Backup the old file to <filename.saved>
  300: #              - Separate the contents of the new file out from the
  301: #                rest of the request.
  302: #              - Write the new file.
  303: #  Parameter:
  304: #     Request - The entire user request.  This consists of a : separated
  305: #               string pushfile:tablename:contents.
  306: #     NOTE:  The contents may have :'s in it as well making things a bit
  307: #            more interesting... but not much.
  308: #  Returns:
  309: #     String to send to client ("ok" or "refused" if bad file).
  310: #
  311: sub PushFile {
  312:     my $request = shift;    
  313:     my ($command, $filename, $contents) = split(":", $request, 3);
  314:     
  315:     #  At this point in time, pushes for only the following tables are
  316:     #  supported:
  317:     #   hosts.tab  ($filename eq host).
  318:     #   domain.tab ($filename eq domain).
  319:     # Construct the destination filename or reject the request.
  320:     #
  321:     # lonManage is supposed to ensure this, however this session could be
  322:     # part of some elaborate spoof that managed somehow to authenticate.
  323:     #
  324: 
  325:     my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir.
  326:     if ($filename eq "host") {
  327: 	$tablefile .= "hosts.tab";
  328:     } elsif ($filename eq "domain") {
  329: 	$tablefile .= "domain.tab";
  330:     } else {
  331: 	return "refused";
  332:     }
  333:     #
  334:     # >copy< the old table to the backup table
  335:     #        don't rename in case system crashes/reboots etc. in the time
  336:     #        window between a rename and write.
  337:     #
  338:     my $backupfile = $tablefile;
  339:     $backupfile    =~ s/\.tab$/.old/;
  340:     if(!CopyFile($tablefile, $backupfile)) {
  341: 	&logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
  342: 	return "error:$!";
  343:     }
  344:     &logthis('<font color="green"> Pushfile: backed up '
  345: 	    .$tablefile." to $backupfile</font>");
  346:     
  347:     #  Install the new file:
  348: 
  349:     if(!InstallFile($tablefile, $contents)) {
  350: 	&logthis('<font color="red"> Pushfile: unable to install '
  351: 	 .$tablefile." $! </font>");
  352: 	return "error:$!";
  353:     }
  354:     else {
  355: 	&logthis('<font color="green"> Installed new '.$tablefile
  356: 		 ."</font>");
  357: 
  358:     }
  359: 
  360: 
  361:     #  Indicate success:
  362:  
  363:     return "ok";
  364: 
  365: }
  366: 
  367: #
  368: #  Called to re-init either lonc or lond.
  369: #
  370: #  Parameters:
  371: #    request   - The full request by the client.  This is of the form
  372: #                reinit:<process>  
  373: #                where <process> is allowed to be either of 
  374: #                lonc or lond
  375: #
  376: #  Returns:
  377: #     The string to be sent back to the client either:
  378: #   ok         - Everything worked just fine.
  379: #   error:why  - There was a failure and why describes the reason.
  380: #
  381: #
  382: sub ReinitProcess {
  383:     my $request = shift;
  384: 
  385: 
  386:     # separate the request (reinit) from the process identifier and
  387:     # validate it producing the name of the .pid file for the process.
  388:     #
  389:     #
  390:     my ($junk, $process) = split(":", $request);
  391:     my $processpidfile = $perlvar{'lonDaemons'}.'/';
  392:     if($process eq 'lonc') {
  393: 	$processpidfile = $processpidfile."lonc.pid";
  394:     } elsif ($process eq 'lond') {
  395: 	$processpidfile = $processpidfile."lond.pid";
  396:     } else {
  397: 	&logthis('<font color="yellow" Invalid reinit request for '.$process
  398: 		 ."</font>");
  399: 	return "error:Invalid process identifier $process";
  400:     }
  401:     &logthis('<font color="red"> Reinitializing '.$process." </font>");
  402:     return 'ok';
  403: }
  404: 
  405: #
  406: #  Convert an error return code from lcpasswd to a string value.
  407: #
  408: sub lcpasswdstrerror {
  409:     my $ErrorCode = shift;
  410:     if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
  411: 	return "lcpasswd Unrecognized error return value ".$ErrorCode;
  412:     } else {
  413: 	return $passwderrors[$ErrorCode];
  414:     }
  415: }
  416: 
  417: #
  418: # Convert an error return code from lcuseradd to a string value:
  419: #
  420: sub lcuseraddstrerror {
  421:     my $ErrorCode = shift;
  422:     if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
  423: 	return "lcuseradd - Unrecognized error code: ".$ErrorCode;
  424:     } else {
  425: 	return $adderrors[$ErrorCode];
  426:     }
  427: }
  428: 
  429: # grabs exception and records it to log before exiting
  430: sub catchexception {
  431:     my ($error)=@_;
  432:     $SIG{'QUIT'}='DEFAULT';
  433:     $SIG{__DIE__}='DEFAULT';
  434:     &logthis("<font color=red>CRITICAL: "
  435:      ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
  436:      ."a crash with this error msg->[$error]</font>");
  437:     &logthis('Famous last words: '.$status.' - '.$lastlog);
  438:     if ($client) { print $client "error: $error\n"; }
  439:     $server->close();
  440:     die($error);
  441: }
  442: 
  443: sub timeout {
  444:     &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
  445:     &catchexception('Timeout');
  446: }
  447: # -------------------------------- Set signal handlers to record abnormal exits
  448: 
  449: $SIG{'QUIT'}=\&catchexception;
  450: $SIG{__DIE__}=\&catchexception;
  451: 
  452: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
  453: &status("Read loncapa.conf and loncapa_apache.conf");
  454: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
  455: %perlvar=%{$perlvarref};
  456: undef $perlvarref;
  457: 
  458: # ----------------------------- Make sure this process is running from user=www
  459: my $wwwid=getpwnam('www');
  460: if ($wwwid!=$<) {
  461:    my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
  462:    my $subj="LON: $currenthostid User ID mismatch";
  463:    system("echo 'User ID mismatch.  lond must be run as user www.' |\
  464:  mailto $emailto -s '$subj' > /dev/null");
  465:    exit 1;
  466: }
  467: 
  468: # --------------------------------------------- Check if other instance running
  469: 
  470: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
  471: 
  472: if (-e $pidfile) {
  473:    my $lfh=IO::File->new("$pidfile");
  474:    my $pide=<$lfh>;
  475:    chomp($pide);
  476:    if (kill 0 => $pide) { die "already running"; }
  477: }
  478: 
  479: # ------------------------------------------------------------- Read hosts file
  480: 
  481: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
  482: 
  483: while (my $configline=<CONFIG>) {
  484:     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
  485:     chomp($ip); $ip=~s/\D+$//;
  486:     $hostid{$ip}=$id;
  487:     $hostdom{$id}=$domain;
  488:     $hostip{$id}=$ip;
  489:     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
  490: }
  491: close(CONFIG);
  492: 
  493: # establish SERVER socket, bind and listen.
  494: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
  495:                                 Type      => SOCK_STREAM,
  496:                                 Proto     => 'tcp',
  497:                                 Reuse     => 1,
  498:                                 Listen    => 10 )
  499:   or die "making socket: $@\n";
  500: 
  501: # --------------------------------------------------------- Do global variables
  502: 
  503: # global variables
  504: 
  505: my %children               = ();       # keys are current child process IDs
  506: my $children               = 0;        # current number of children
  507: 
  508: sub REAPER {                        # takes care of dead children
  509:     $SIG{CHLD} = \&REAPER;
  510:     my $pid = wait;
  511:     if (defined($children{$pid})) {
  512: 	&logthis("Child $pid died");
  513: 	$children --;
  514: 	delete $children{$pid};
  515:     } else {
  516: 	&logthis("Unknown Child $pid died");
  517:     }
  518: }
  519: 
  520: sub HUNTSMAN {                      # signal handler for SIGINT
  521:     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
  522:     kill 'INT' => keys %children;
  523:     &logthis("Free socket: ".shutdown($server,2)); # free up socket
  524:     my $execdir=$perlvar{'lonDaemons'};
  525:     unlink("$execdir/logs/lond.pid");
  526:     &logthis("<font color=red>CRITICAL: Shutting down</font>");
  527:     exit;                           # clean up with dignity
  528: }
  529: 
  530: sub HUPSMAN {                      # signal handler for SIGHUP
  531:     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
  532:     kill 'INT' => keys %children;
  533:     &logthis("Free socket: ".shutdown($server,2)); # free up socket
  534:     &logthis("<font color=red>CRITICAL: Restarting</font>");
  535:     my $execdir=$perlvar{'lonDaemons'};
  536:     unlink("$execdir/logs/lond.pid");
  537:     exec("$execdir/lond");         # here we go again
  538: }
  539: 
  540: #
  541: #   Called in response to a USR2 signal.
  542: #   - Reread hosts.tab
  543: #   - All children connected to hosts that were removed from hosts.tab
  544: #     are killed via SIGINT
  545: #   - All children connected to previously existing hosts are sent SIGUSR1
  546: #   - Our internal hosts hash is updated to reflect the new contents of
  547: #     hosts.tab causing connections from hosts added to hosts.tab to
  548: #     now be honored.
  549: #
  550: sub UpdateHosts {
  551: }
  552: 
  553: sub checkchildren {
  554:     &initnewstatus();
  555:     &logstatus();
  556:     &logthis('Going to check on the children');
  557:     my $docdir=$perlvar{'lonDocRoot'};
  558:     foreach (sort keys %children) {
  559: 	sleep 1;
  560:         unless (kill 'USR1' => $_) {
  561: 	    &logthis ('Child '.$_.' is dead');
  562:             &logstatus($$.' is dead');
  563:         } 
  564:     }
  565:     sleep 5;
  566:     $SIG{ALRM} = sub { die "timeout" };
  567:     $SIG{__DIE__} = 'DEFAULT';
  568:     foreach (sort keys %children) {
  569:         unless (-e "$docdir/lon-status/londchld/$_.txt") {
  570:           eval {
  571:             alarm(300);
  572: 	    &logthis('Child '.$_.' did not respond');
  573: 	    kill 9 => $_;
  574: 	    #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
  575: 	    #$subj="LON: $currenthostid killed lond process $_";
  576: 	    #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
  577: 	    #$execdir=$perlvar{'lonDaemons'};
  578: 	    #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
  579: 	    alarm(0);
  580: 	  }
  581:         }
  582:     }
  583:     $SIG{ALRM} = 'DEFAULT';
  584:     $SIG{__DIE__} = \&cathcexception;
  585: }
  586: 
  587: # --------------------------------------------------------------------- Logging
  588: 
  589: sub logthis {
  590:     my $message=shift;
  591:     my $execdir=$perlvar{'lonDaemons'};
  592:     my $fh=IO::File->new(">>$execdir/logs/lond.log");
  593:     my $now=time;
  594:     my $local=localtime($now);
  595:     $lastlog=$local.': '.$message;
  596:     print $fh "$local ($$): $message\n";
  597: }
  598: 
  599: # ------------------------- Conditional log if $DEBUG true.
  600: sub Debug {
  601:     my $message = shift;
  602:     if($DEBUG) {
  603: 	&logthis($message);
  604:     }
  605: }
  606: # ------------------------------------------------------------------ Log status
  607: 
  608: sub logstatus {
  609:     my $docdir=$perlvar{'lonDocRoot'};
  610:     {
  611:     my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
  612:     print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
  613:     $fh->close();
  614:     }
  615:     {
  616: 	my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
  617:         print $fh $status."\n".$lastlog."\n".time;
  618:         $fh->close();
  619:     }
  620: }
  621: 
  622: sub initnewstatus {
  623:     my $docdir=$perlvar{'lonDocRoot'};
  624:     my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
  625:     my $now=time;
  626:     my $local=localtime($now);
  627:     print $fh "LOND status $local - parent $$\n\n";
  628:     opendir(DIR,"$docdir/lon-status/londchld");
  629:     while (my $filename=readdir(DIR)) {
  630:         unlink("$docdir/lon-status/londchld/$filename");
  631:     }
  632:     closedir(DIR);
  633: }
  634: 
  635: # -------------------------------------------------------------- Status setting
  636: 
  637: sub status {
  638:     my $what=shift;
  639:     my $now=time;
  640:     my $local=localtime($now);
  641:     $status=$local.': '.$what;
  642:     $0='lond: '.$what.' '.$local;
  643: }
  644: 
  645: # -------------------------------------------------------- Escape Special Chars
  646: 
  647: sub escape {
  648:     my $str=shift;
  649:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
  650:     return $str;
  651: }
  652: 
  653: # ----------------------------------------------------- Un-Escape Special Chars
  654: 
  655: sub unescape {
  656:     my $str=shift;
  657:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  658:     return $str;
  659: }
  660: 
  661: # ----------------------------------------------------------- Send USR1 to lonc
  662: 
  663: sub reconlonc {
  664:     my $peerfile=shift;
  665:     &logthis("Trying to reconnect for $peerfile");
  666:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
  667:     if (my $fh=IO::File->new("$loncfile")) {
  668: 	my $loncpid=<$fh>;
  669:         chomp($loncpid);
  670:         if (kill 0 => $loncpid) {
  671: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
  672:             kill USR1 => $loncpid;
  673:         } else {
  674: 	    &logthis(
  675:               "<font color=red>CRITICAL: "
  676:              ."lonc at pid $loncpid not responding, giving up</font>");
  677:         }
  678:     } else {
  679:       &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
  680:     }
  681: }
  682: 
  683: # -------------------------------------------------- Non-critical communication
  684: 
  685: sub subreply {
  686:     my ($cmd,$server)=@_;
  687:     my $peerfile="$perlvar{'lonSockDir'}/$server";
  688:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  689:                                       Type    => SOCK_STREAM,
  690:                                       Timeout => 10)
  691:        or return "con_lost";
  692:     print $sclient "$cmd\n";
  693:     my $answer=<$sclient>;
  694:     chomp($answer);
  695:     if (!$answer) { $answer="con_lost"; }
  696:     return $answer;
  697: }
  698: 
  699: sub reply {
  700:   my ($cmd,$server)=@_;
  701:   my $answer;
  702:   if ($server ne $currenthostid) { 
  703:     $answer=subreply($cmd,$server);
  704:     if ($answer eq 'con_lost') {
  705: 	$answer=subreply("ping",$server);
  706:         if ($answer ne $server) {
  707: 	    &logthis("sub reply: answer != server answer is $answer, server is $server");
  708:            &reconlonc("$perlvar{'lonSockDir'}/$server");
  709:         }
  710:         $answer=subreply($cmd,$server);
  711:     }
  712:   } else {
  713:     $answer='self_reply';
  714:   } 
  715:   return $answer;
  716: }
  717: 
  718: # -------------------------------------------------------------- Talk to lonsql
  719: 
  720: sub sqlreply {
  721:     my ($cmd)=@_;
  722:     my $answer=subsqlreply($cmd);
  723:     if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
  724:     return $answer;
  725: }
  726: 
  727: sub subsqlreply {
  728:     my ($cmd)=@_;
  729:     my $unixsock="mysqlsock";
  730:     my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
  731:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  732:                                       Type    => SOCK_STREAM,
  733:                                       Timeout => 10)
  734:        or return "con_lost";
  735:     print $sclient "$cmd\n";
  736:     my $answer=<$sclient>;
  737:     chomp($answer);
  738:     if (!$answer) { $answer="con_lost"; }
  739:     return $answer;
  740: }
  741: 
  742: # -------------------------------------------- Return path to profile directory
  743: 
  744: sub propath {
  745:     my ($udom,$uname)=@_;
  746:     $udom=~s/\W//g;
  747:     $uname=~s/\W//g;
  748:     my $subdir=$uname.'__';
  749:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
  750:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
  751:     return $proname;
  752: } 
  753: 
  754: # --------------------------------------- Is this the home server of an author?
  755: 
  756: sub ishome {
  757:     my $author=shift;
  758:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
  759:     my ($udom,$uname)=split(/\//,$author);
  760:     my $proname=propath($udom,$uname);
  761:     if (-e $proname) {
  762: 	return 'owner';
  763:     } else {
  764:         return 'not_owner';
  765:     }
  766: }
  767: 
  768: # ======================================================= Continue main program
  769: # ---------------------------------------------------- Fork once and dissociate
  770: 
  771: my $fpid=fork;
  772: exit if $fpid;
  773: die "Couldn't fork: $!" unless defined ($fpid);
  774: 
  775: POSIX::setsid() or die "Can't start new session: $!";
  776: 
  777: # ------------------------------------------------------- Write our PID on disk
  778: 
  779: my $execdir=$perlvar{'lonDaemons'};
  780: open (PIDSAVE,">$execdir/logs/lond.pid");
  781: print PIDSAVE "$$\n";
  782: close(PIDSAVE);
  783: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
  784: &status('Starting');
  785: 
  786: 
  787: 
  788: # ----------------------------------------------------- Install signal handlers
  789: 
  790: 
  791: $SIG{CHLD} = \&REAPER;
  792: $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
  793: $SIG{HUP}  = \&HUPSMAN;
  794: $SIG{USR1} = \&checkchildren;
  795: $SIG{USR2} = \&UpdateHosts;
  796: 
  797: 
  798: # --------------------------------------------------------------
  799: #   Accept connections.  When a connection comes in, it is validated
  800: #   and if good, a child process is created to process transactions
  801: #   along the connection.
  802: 
  803: while (1) {
  804:     $client = $server->accept() or next;
  805:     make_new_child($client);
  806: }
  807: 
  808: sub make_new_child {
  809:     my $pid;
  810:     my $cipher;
  811:     my $sigset;
  812: 
  813:     $client = shift;
  814:     &logthis("Attempting to start child");    
  815:     # block signal for fork
  816:     $sigset = POSIX::SigSet->new(SIGINT);
  817:     sigprocmask(SIG_BLOCK, $sigset)
  818:         or die "Can't block SIGINT for fork: $!\n";
  819: 
  820:     die "fork: $!" unless defined ($pid = fork);
  821:     
  822:     if ($pid) {
  823:         # Parent records the child's birth and returns.
  824:         sigprocmask(SIG_UNBLOCK, $sigset)
  825:             or die "Can't unblock SIGINT for fork: $!\n";
  826:         $children{$pid} = 1;
  827:         $children++;
  828:         &status('Started child '.$pid);
  829:         return;
  830:     } else {
  831:         # Child can *not* return from this subroutine.
  832:         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
  833:         $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns 
  834:                                 #don't get intercepted
  835:         $SIG{USR1}= \&logstatus;
  836:         $SIG{ALRM}= \&timeout;
  837:         $lastlog='Forked ';
  838:         $status='Forked';
  839: 
  840:         # unblock signals
  841:         sigprocmask(SIG_UNBLOCK, $sigset)
  842:             or die "Can't unblock SIGINT for fork: $!\n";
  843: 
  844:         my $tmpsnum=0;
  845: #---------------------------------------------------- kerberos 5 initialization
  846:         &Authen::Krb5::init_context();
  847:         &Authen::Krb5::init_ets();
  848: 
  849:             &status('Accepted connection');
  850: # =============================================================================
  851:             # do something with the connection
  852: # -----------------------------------------------------------------------------
  853: 	    $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
  854: 	                                      # connection liveness.
  855:             # see if we know client and check for spoof IP by challenge
  856: 		my $caller = getpeername($client);
  857:             my ($port,$iaddr)=unpack_sockaddr_in($caller);
  858:             $clientip=inet_ntoa($iaddr);
  859:             my $clientrec=($hostid{$clientip} ne undef);
  860:             &logthis(
  861: "<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
  862:             );
  863:             &status("Connecting $clientip ($hostid{$clientip})"); 
  864:             my $clientok;
  865:             if ($clientrec) {
  866: 	      &status("Waiting for init from $clientip ($hostid{$clientip})");
  867: 	      my $remotereq=<$client>;
  868:               $remotereq=~s/[^\w:]//g;
  869:               if ($remotereq =~ /^init/) {
  870: 		  &sethost("sethost:$perlvar{'lonHostID'}");
  871: 		  my $challenge="$$".time;
  872:                   print $client "$challenge\n";
  873:                   &status(
  874:            "Waiting for challenge reply from $clientip ($hostid{$clientip})"); 
  875:                   $remotereq=<$client>;
  876:                   $remotereq=~s/\W//g;
  877:                   if ($challenge eq $remotereq) {
  878: 		      $clientok=1;
  879:                       print $client "ok\n";
  880:                   } else {
  881: 		      &logthis(
  882:  "<font color=blue>WARNING: $clientip did not reply challenge</font>");
  883:                       &status('No challenge reply '.$clientip);
  884:                   }
  885:               } else {
  886: 		  &logthis(
  887:                     "<font color=blue>WARNING: "
  888:                    ."$clientip failed to initialize: >$remotereq< </font>");
  889:                   &status('No init '.$clientip);
  890:               }
  891: 	    } else {
  892:               &logthis(
  893:  "<font color=blue>WARNING: Unknown client $clientip</font>");
  894:               &status('Hung up on '.$clientip);
  895:             }
  896:             if ($clientok) {
  897: # ---------------- New known client connecting, could mean machine online again
  898: 
  899: 		foreach my $id (keys(%hostip)) {
  900: 		    if ($hostip{$id} ne $clientip ||
  901: 		       $hostip{$currenthostid} eq $clientip) {
  902: 			# no need to try to do recon's to myself
  903: 			next;
  904: 		    }
  905: 		    &reconlonc("$perlvar{'lonSockDir'}/$id");
  906: 		}
  907: 		&logthis("<font color=green>Established connection: $hostid{$clientip}</font>");
  908:               &status('Will listen to '.$hostid{$clientip});
  909: # ------------------------------------------------------------ Process requests
  910:               while (my $userinput=<$client>) {
  911:                 chomp($userinput);
  912: 		Debug("Request = $userinput\n");
  913:                 &status('Processing '.$hostid{$clientip}.': '.$userinput);
  914:                 my $wasenc=0;
  915:                 alarm(120);
  916: # ------------------------------------------------------------ See if encrypted
  917: 		if ($userinput =~ /^enc/) {
  918: 		  if ($cipher) {
  919:                     my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
  920: 		    $userinput='';
  921:                     for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
  922:                        $userinput.=
  923: 			   $cipher->decrypt(
  924:                             pack("H16",substr($encinput,$encidx,16))
  925:                            );
  926: 		    }
  927: 		    $userinput=substr($userinput,0,$cmdlength);
  928:                     $wasenc=1;
  929: 		}
  930: 	      }
  931: 	  
  932: # ------------------------------------------------------------- Normal commands
  933: # ------------------------------------------------------------------------ ping
  934: 		   if ($userinput =~ /^ping/) {
  935:                        print $client "$currenthostid\n";
  936: # ------------------------------------------------------------------------ pong
  937: 		   }elsif ($userinput =~ /^pong/) {
  938:                        my $reply=&reply("ping",$hostid{$clientip});
  939:                        print $client "$currenthostid:$reply\n"; 
  940: # ------------------------------------------------------------------------ ekey
  941: 		   } elsif ($userinput =~ /^ekey/) {
  942:                        my $buildkey=time.$$.int(rand 100000);
  943:                        $buildkey=~tr/1-6/A-F/;
  944:                        $buildkey=int(rand 100000).$buildkey.int(rand 100000);
  945:                        my $key=$currenthostid.$hostid{$clientip};
  946:                        $key=~tr/a-z/A-Z/;
  947:                        $key=~tr/G-P/0-9/;
  948:                        $key=~tr/Q-Z/0-9/;
  949:                        $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
  950:                        $key=substr($key,0,32);
  951:                        my $cipherkey=pack("H32",$key);
  952:                        $cipher=new IDEA $cipherkey;
  953:                        print $client "$buildkey\n"; 
  954: # ------------------------------------------------------------------------ load
  955: 		   } elsif ($userinput =~ /^load/) {
  956:                        my $loadavg;
  957:                        {
  958:                           my $loadfile=IO::File->new('/proc/loadavg');
  959:                           $loadavg=<$loadfile>;
  960:                        }
  961:                        $loadavg =~ s/\s.*//g;
  962: 		       my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
  963: 		       print $client "$loadpercent\n";
  964: # -------------------------------------------------------------------- userload
  965: 		   } elsif ($userinput =~ /^userload/) {
  966: 		       my $userloadpercent=&userload();
  967: 		       print $client "$userloadpercent\n";
  968: 
  969: #
  970: #        Transactions requiring encryption:
  971: #
  972: # ----------------------------------------------------------------- currentauth
  973: 		   } elsif ($userinput =~ /^currentauth/) {
  974: 		     if ($wasenc==1) {
  975:                        my ($cmd,$udom,$uname)=split(/:/,$userinput);
  976: 		       my $result = GetAuthType($udom, $uname);
  977: 		       if($result eq "nouser") {
  978: 			   print $client "unknown_user\n";
  979: 		       }
  980: 		       else {
  981: 			   print $client "$result\n"
  982: 		       }
  983: 		     } else {
  984: 		       print $client "refused\n";
  985: 		     }
  986: #--------------------------------------------------------------------- pushfile
  987: 		   } elsif($userinput =~ /^pushfile/) { 
  988: 		       if($wasenc == 1) {
  989: 			   my $cert = GetCertificate($userinput);
  990: 			   if(ValidManager($cert)) {
  991: 			       my $reply = PushFile($userinput);
  992: 			       print $client "$reply\n";
  993: 			   } else {
  994: 			       print $client "refused\n";
  995: 			   } 
  996: 		       } else {
  997: 			   print $client "refused\n";
  998: 		       }
  999: #--------------------------------------------------------------------- reinit
 1000: 		   } elsif($userinput =~ /^reinit/) {
 1001: 		       if ($wasenc == 1) {
 1002: 			   my $cert = GetCertificate($userinput);
 1003: 			   if(ValidManager($cert)) {
 1004: 			       chomp($userinput);
 1005: 			       my $reply = ReinitProcess($userinput);
 1006: 			       print $client  "$reply\n";
 1007: 			   } else {
 1008: 			       print $client "refused\n";
 1009: 			   }
 1010: 		       } else {
 1011: 			   print $client "refused\n";
 1012: 		       }
 1013: # ------------------------------------------------------------------------ auth
 1014:                    } elsif ($userinput =~ /^auth/) {
 1015: 		     if ($wasenc==1) {
 1016:                        my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
 1017:                        chomp($upass);
 1018:                        $upass=unescape($upass);
 1019:                        my $proname=propath($udom,$uname);
 1020:                        my $passfilename="$proname/passwd";
 1021:                        if (-e $passfilename) {
 1022:                           my $pf = IO::File->new($passfilename);
 1023:                           my $realpasswd=<$pf>;
 1024:                           chomp($realpasswd);
 1025:                           my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
 1026:                           my $pwdcorrect=0;
 1027:                           if ($howpwd eq 'internal') {
 1028: 			      &Debug("Internal auth");
 1029: 			      $pwdcorrect=
 1030: 				  (crypt($upass,$contentpwd) eq $contentpwd);
 1031:                           } elsif ($howpwd eq 'unix') {
 1032: 			      &Debug("Unix auth");
 1033:                               if((getpwnam($uname))[1] eq "") { #no such user!
 1034: 				  $pwdcorrect = 0;
 1035: 			      } else {
 1036: 				  $contentpwd=(getpwnam($uname))[1];
 1037: 				  my $pwauth_path="/usr/local/sbin/pwauth";
 1038: 				  unless ($contentpwd eq 'x') {
 1039: 				      $pwdcorrect=
 1040: 					  (crypt($upass,$contentpwd) eq 
 1041: 					   $contentpwd);
 1042: 				  }
 1043: 		  
 1044: 			      elsif (-e $pwauth_path) {
 1045: 				  open PWAUTH, "|$pwauth_path" or
 1046: 				      die "Cannot invoke authentication";
 1047: 				  print PWAUTH "$uname\n$upass\n";
 1048: 				  close PWAUTH;
 1049: 				  $pwdcorrect=!$?;
 1050: 			      }
 1051: 			      }
 1052:                           } elsif ($howpwd eq 'krb4') {
 1053:                               my $null=pack("C",0);
 1054:                               unless ($upass=~/$null/) {
 1055:                                   my $krb4_error = &Authen::Krb4::get_pw_in_tkt
 1056:                                       ($uname,"",$contentpwd,'krbtgt',
 1057:                                        $contentpwd,1,$upass);
 1058:                                   if (!$krb4_error) {
 1059:                                       $pwdcorrect = 1;
 1060:                                   } else { 
 1061:                                       $pwdcorrect=0; 
 1062:                                       # log error if it is not a bad password
 1063:                                       if ($krb4_error != 62) {
 1064:        &logthis('krb4:'.$uname.','.$contentpwd.','.
 1065:                 &Authen::Krb4::get_err_txt($Authen::Krb4::error));
 1066:                                       }
 1067:                                   }
 1068:                               }
 1069:                           } elsif ($howpwd eq 'krb5') {
 1070: 			      my $null=pack("C",0);
 1071: 			      unless ($upass=~/$null/) {
 1072: 				  my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
 1073: 				  my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
 1074: 				  my $krbserver=&Authen::Krb5::parse_name($krbservice);
 1075: 				  my $credentials=&Authen::Krb5::cc_default();
 1076: 				  $credentials->initialize($krbclient);
 1077: 				  my $krbreturn = 
 1078: 				    &Authen::Krb5::get_in_tkt_with_password(
 1079: 				     $krbclient,$krbserver,$upass,$credentials);
 1080: #				  unless ($krbreturn) {
 1081: #				      &logthis("Krb5 Error: ".
 1082: #					       &Authen::Krb5::error());
 1083: #				  }
 1084: 				  $pwdcorrect = ($krbreturn == 1);
 1085: 			   } else { $pwdcorrect=0; }
 1086:                           } elsif ($howpwd eq 'localauth') {
 1087: 			    $pwdcorrect=&localauth::localauth($uname,$upass,
 1088: 							      $contentpwd);
 1089: 			  }
 1090:                           if ($pwdcorrect) {
 1091:                              print $client "authorized\n";
 1092:                           } else {
 1093:                              print $client "non_authorized\n";
 1094:                           }  
 1095: 		       } else {
 1096:                           print $client "unknown_user\n";
 1097:                        }
 1098: 		     } else {
 1099: 		       print $client "refused\n";
 1100: 		     }
 1101: # ---------------------------------------------------------------------- passwd
 1102:                    } elsif ($userinput =~ /^passwd/) {
 1103: 		     if ($wasenc==1) {
 1104:                        my 
 1105:                        ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
 1106:                        chomp($npass);
 1107:                        $upass=&unescape($upass);
 1108:                        $npass=&unescape($npass);
 1109: 		       &Debug("Trying to change password for $uname");
 1110: 		       my $proname=propath($udom,$uname);
 1111:                        my $passfilename="$proname/passwd";
 1112:                        if (-e $passfilename) {
 1113: 			   my $realpasswd;
 1114:                           { my $pf = IO::File->new($passfilename);
 1115: 			    $realpasswd=<$pf>; }
 1116:                           chomp($realpasswd);
 1117:                           my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
 1118:                           if ($howpwd eq 'internal') {
 1119: 			   &Debug("internal auth");
 1120: 			   if (crypt($upass,$contentpwd) eq $contentpwd) {
 1121: 			     my $salt=time;
 1122:                              $salt=substr($salt,6,2);
 1123: 			     my $ncpass=crypt($npass,$salt);
 1124:                              {
 1125: 				 my $pf;
 1126: 				 if ($pf = IO::File->new(">$passfilename")) {
 1127: 				     print $pf "internal:$ncpass\n";
 1128: 				     &logthis("Result of password change for $uname: pwchange_success");
 1129: 				     print $client "ok\n";
 1130: 				 } else {
 1131: 				     &logthis("Unable to open $uname passwd to change password");
 1132: 				     print $client "non_authorized\n";
 1133: 				 }
 1134: 			     }             
 1135: 			     
 1136:                            } else {
 1137:                              print $client "non_authorized\n";
 1138:                            }
 1139:                           } elsif ($howpwd eq 'unix') {
 1140: 			      # Unix means we have to access /etc/password
 1141: 			      # one way or another.
 1142: 			      # First: Make sure the current password is
 1143: 			      #        correct
 1144: 			      &Debug("auth is unix");
 1145: 			      $contentpwd=(getpwnam($uname))[1];
 1146: 			      my $pwdcorrect = "0";
 1147: 			      my $pwauth_path="/usr/local/sbin/pwauth";
 1148: 			      unless ($contentpwd eq 'x') {
 1149: 				  $pwdcorrect=
 1150:                                     (crypt($upass,$contentpwd) eq $contentpwd);
 1151: 			      } elsif (-e $pwauth_path) {
 1152: 				  open PWAUTH, "|$pwauth_path" or
 1153: 				      die "Cannot invoke authentication";
 1154: 				  print PWAUTH "$uname\n$upass\n";
 1155: 				  close PWAUTH;
 1156: 				  &Debug("exited pwauth with $? ($uname,$upass) ");
 1157: 				  $pwdcorrect=($? == 0);
 1158: 			      }
 1159: 			     if ($pwdcorrect) {
 1160: 				 my $execdir=$perlvar{'lonDaemons'};
 1161: 				 &Debug("Opening lcpasswd pipeline");
 1162: 				 my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
 1163: 				 print $pf "$uname\n$npass\n$npass\n";
 1164: 				 close $pf;
 1165: 				 my $err = $?;
 1166: 				 my $result = ($err>0 ? 'pwchange_failure' 
 1167: 					       : 'ok');
 1168: 				 &logthis("Result of password change for $uname: ".
 1169: 					  &lcpasswdstrerror($?));
 1170: 				 print $client "$result\n";
 1171: 			     } else {
 1172: 				 print $client "non_authorized\n";
 1173: 			     }
 1174: 			  } else {
 1175:                             print $client "auth_mode_error\n";
 1176:                           }  
 1177: 		       } else {
 1178:                           print $client "unknown_user\n";
 1179:                        }
 1180: 		     } else {
 1181: 		       print $client "refused\n";
 1182: 		     }
 1183: # -------------------------------------------------------------------- makeuser
 1184:                    } elsif ($userinput =~ /^makeuser/) {
 1185: 		     &Debug("Make user received");
 1186:     	             my $oldumask=umask(0077);
 1187: 		     if ($wasenc==1) {
 1188:                        my 
 1189:                        ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
 1190: 		       &Debug("cmd =".$cmd." $udom =".$udom.
 1191: 				    " uname=".$uname);
 1192:                        chomp($npass);
 1193:                        $npass=&unescape($npass);
 1194:                        my $proname=propath($udom,$uname);
 1195:                        my $passfilename="$proname/passwd";
 1196: 		       &Debug("Password file created will be:".
 1197: 				    $passfilename);
 1198:                        if (-e $passfilename) {
 1199: 			   print $client "already_exists\n";
 1200:                        } elsif ($udom ne $currentdomainid) {
 1201:                            print $client "not_right_domain\n";
 1202:                        } else {
 1203:                            my @fpparts=split(/\//,$proname);
 1204:                            my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
 1205:                            my $fperror='';
 1206:                            for (my $i=3;$i<=$#fpparts;$i++) {
 1207:                                $fpnow.='/'.$fpparts[$i]; 
 1208:                                unless (-e $fpnow) {
 1209: 				   unless (mkdir($fpnow,0777)) {
 1210:                                       $fperror="error: ".($!+0)
 1211: 					  ." mkdir failed while attempting "
 1212:                                               ."makeuser\n";
 1213:                                    }
 1214:                                }
 1215:                            }
 1216:                            unless ($fperror) {
 1217: 			       my $result=&make_passwd_file($uname, $umode,$npass,
 1218: 							    $passfilename);
 1219: 			       print $client $result;
 1220:                            } else {
 1221:                                print $client "$fperror\n";
 1222:                            }
 1223:                        }
 1224: 		     } else {
 1225: 		       print $client "refused\n";
 1226: 		     }
 1227: 		     umask($oldumask);
 1228: # -------------------------------------------------------------- changeuserauth
 1229:                    } elsif ($userinput =~ /^changeuserauth/) {
 1230: 		       &Debug("Changing authorization");
 1231: 		      if ($wasenc==1) {
 1232:                        my 
 1233: 		       ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
 1234:                        chomp($npass);
 1235: 		       &Debug("cmd = ".$cmd." domain= ".$udom.
 1236: 			      "uname =".$uname." umode= ".$umode);
 1237:                        $npass=&unescape($npass);
 1238:                        my $proname=&propath($udom,$uname);
 1239:                        my $passfilename="$proname/passwd";
 1240: 		       if ($udom ne $currentdomainid) {
 1241:                            print $client "not_right_domain\n";
 1242:                        } else {
 1243: 			   my $result=&make_passwd_file($uname, $umode,$npass,
 1244: 							$passfilename);
 1245: 			   print $client $result;
 1246:                        }
 1247: 		     } else {
 1248: 		       print $client "refused\n";
 1249: 		     }
 1250: # ------------------------------------------------------------------------ home
 1251:                    } elsif ($userinput =~ /^home/) {
 1252:                        my ($cmd,$udom,$uname)=split(/:/,$userinput);
 1253:                        chomp($uname);
 1254:                        my $proname=propath($udom,$uname);
 1255:                        if (-e $proname) {
 1256:                           print $client "found\n";
 1257:                        } else {
 1258: 			  print $client "not_found\n";
 1259:                        }
 1260: # ---------------------------------------------------------------------- update
 1261:                    } elsif ($userinput =~ /^update/) {
 1262:                        my ($cmd,$fname)=split(/:/,$userinput);
 1263:                        my $ownership=ishome($fname);
 1264:                        if ($ownership eq 'not_owner') {
 1265:                         if (-e $fname) {
 1266:                           my ($dev,$ino,$mode,$nlink,
 1267:                               $uid,$gid,$rdev,$size,
 1268:                               $atime,$mtime,$ctime,
 1269:                               $blksize,$blocks)=stat($fname);
 1270:                           my $now=time;
 1271:                           my $since=$now-$atime;
 1272:                           if ($since>$perlvar{'lonExpire'}) {
 1273:                               my $reply=
 1274:                                     &reply("unsub:$fname","$hostid{$clientip}");
 1275:                               unlink("$fname");
 1276:                           } else {
 1277: 			     my $transname="$fname.in.transfer";
 1278:                              my $remoteurl=
 1279:                                     reply("sub:$fname","$hostid{$clientip}");
 1280:                              my $response;
 1281:                               {
 1282:                              my $ua=new LWP::UserAgent;
 1283:                              my $request=new HTTP::Request('GET',"$remoteurl");
 1284:                              $response=$ua->request($request,$transname);
 1285: 			      }
 1286:                              if ($response->is_error()) {
 1287: 				 unlink($transname);
 1288:                                  my $message=$response->status_line;
 1289:                                  &logthis(
 1290:                                   "LWP GET: $message for $fname ($remoteurl)");
 1291:                              } else {
 1292: 	                         if ($remoteurl!~/\.meta$/) {
 1293:                                   my $ua=new LWP::UserAgent;
 1294:                                   my $mrequest=
 1295:                                    new HTTP::Request('GET',$remoteurl.'.meta');
 1296:                                   my $mresponse=
 1297:                                    $ua->request($mrequest,$fname.'.meta');
 1298:                                   if ($mresponse->is_error()) {
 1299: 		                    unlink($fname.'.meta');
 1300:                                   }
 1301: 	                         }
 1302:                                  rename($transname,$fname);
 1303: 			     }
 1304:                           }
 1305:                           print $client "ok\n";
 1306:                         } else {
 1307:                           print $client "not_found\n";
 1308:                         }
 1309: 		       } else {
 1310: 			print $client "rejected\n";
 1311:                        }
 1312: # -------------------------------------- fetch a user file from a remote server
 1313:                    } elsif ($userinput =~ /^fetchuserfile/) {
 1314:                       my ($cmd,$fname)=split(/:/,$userinput);
 1315: 		      my ($udom,$uname,$ufile)=split(/\//,$fname);
 1316:                       my $udir=propath($udom,$uname).'/userfiles';
 1317:                       unless (-e $udir) { mkdir($udir,0770); }
 1318:                        if (-e $udir) {
 1319:                        $ufile=~s/^[\.\~]+//;
 1320:                        $ufile=~s/\///g;
 1321:                        my $transname=$udir.'/'.$ufile;
 1322:                        my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
 1323:                              my $response;
 1324:                               {
 1325:                              my $ua=new LWP::UserAgent;
 1326:                              my $request=new HTTP::Request('GET',"$remoteurl");
 1327:                              $response=$ua->request($request,$transname);
 1328: 			      }
 1329:                              if ($response->is_error()) {
 1330: 				 unlink($transname);
 1331:                                  my $message=$response->status_line;
 1332:                                  &logthis(
 1333:                                   "LWP GET: $message for $fname ($remoteurl)");
 1334: 				 print $client "failed\n";
 1335:                              } else {
 1336:                                  print $client "ok\n";
 1337:                              }
 1338:                      } else {
 1339:                        print $client "not_home\n";
 1340:                      } 
 1341: # ------------------------------------------ authenticate access to a user file
 1342:                    } elsif ($userinput =~ /^tokenauthuserfile/) {
 1343:                        my ($cmd,$fname,$session)=split(/:/,$userinput);
 1344:                        chomp($session);
 1345:                        my $reply='non_auth';
 1346:                        if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
 1347: 				$session.'.id')) {
 1348: 			   while (my $line=<ENVIN>) {
 1349: 			       if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
 1350: 			   }
 1351: 			   close(ENVIN);
 1352: 			   print $client $reply."\n";
 1353: 		       } else {
 1354: 			   print $client "invalid_token\n";
 1355:                        }
 1356: # ----------------------------------------------------------------- unsubscribe
 1357:                    } elsif ($userinput =~ /^unsub/) {
 1358:                        my ($cmd,$fname)=split(/:/,$userinput);
 1359:                        if (-e $fname) {
 1360: 			   print $client &unsub($client,$fname,$clientip);
 1361:                        } else {
 1362: 			   print $client "not_found\n";
 1363:                        }
 1364: # ------------------------------------------------------------------- subscribe
 1365:                    } elsif ($userinput =~ /^sub/) {
 1366: 		       print $client &subscribe($userinput,$clientip);
 1367: # ------------------------------------------------------------- current version
 1368:                    } elsif ($userinput =~ /^currentversion/) {
 1369:                        my ($cmd,$fname)=split(/:/,$userinput);
 1370: 		       print $client &currentversion($fname)."\n";
 1371: # ------------------------------------------------------------------------- log
 1372:                    } elsif ($userinput =~ /^log/) {
 1373:                        my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
 1374:                        chomp($what);
 1375:                        my $proname=propath($udom,$uname);
 1376:                        my $now=time;
 1377:                        {
 1378: 			 my $hfh;
 1379: 			 if ($hfh=IO::File->new(">>$proname/activity.log")) { 
 1380:                             print $hfh "$now:$hostid{$clientip}:$what\n";
 1381:                             print $client "ok\n"; 
 1382: 			} else {
 1383:                             print $client "error: ".($!+0)
 1384: 				." IO::File->new Failed "
 1385:                                     ."while attempting log\n";
 1386: 		        }
 1387: 		       }
 1388: # ------------------------------------------------------------------------- put
 1389:                    } elsif ($userinput =~ /^put/) {
 1390:                       my ($cmd,$udom,$uname,$namespace,$what)
 1391:                           =split(/:/,$userinput);
 1392:                       $namespace=~s/\//\_/g;
 1393:                       $namespace=~s/\W//g;
 1394:                       if ($namespace ne 'roles') {
 1395:                        chomp($what);
 1396:                        my $proname=propath($udom,$uname);
 1397:                        my $now=time;
 1398:                        unless ($namespace=~/^nohist\_/) {
 1399: 			   my $hfh;
 1400: 			   if (
 1401:                              $hfh=IO::File->new(">>$proname/$namespace.hist")
 1402: 			       ) { print $hfh "P:$now:$what\n"; }
 1403: 		       }
 1404:                        my @pairs=split(/\&/,$what);
 1405: 		       my %hash;
 1406: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
 1407:                            foreach my $pair (@pairs) {
 1408: 			       my ($key,$value)=split(/=/,$pair);
 1409:                                $hash{$key}=$value;
 1410:                            }
 1411: 			   if (untie(%hash)) {
 1412:                               print $client "ok\n";
 1413:                            } else {
 1414:                               print $client "error: ".($!+0)
 1415: 				  ." untie(GDBM) failed ".
 1416:                                       "while attempting put\n";
 1417:                            }
 1418:                        } else {
 1419:                            print $client "error: ".($!)
 1420: 			       ." tie(GDBM) Failed ".
 1421:                                    "while attempting put\n";
 1422:                        }
 1423: 		      } else {
 1424:                           print $client "refused\n";
 1425:                       }
 1426: # -------------------------------------------------------------------- rolesput
 1427:                    } elsif ($userinput =~ /^rolesput/) {
 1428: 		       &Debug("rolesput");
 1429: 		    if ($wasenc==1) {
 1430:                        my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
 1431:                           =split(/:/,$userinput);
 1432: 		       &Debug("cmd = ".$cmd." exedom= ".$exedom.
 1433: 				    "user = ".$exeuser." udom=".$udom.
 1434: 				    "what = ".$what);
 1435:                        my $namespace='roles';
 1436:                        chomp($what);
 1437:                        my $proname=propath($udom,$uname);
 1438:                        my $now=time;
 1439:                        {
 1440: 			   my $hfh;
 1441: 			   if (
 1442:                              $hfh=IO::File->new(">>$proname/$namespace.hist")
 1443: 			       ) { 
 1444:                                   print $hfh "P:$now:$exedom:$exeuser:$what\n";
 1445:                                  }
 1446: 		       }
 1447:                        my @pairs=split(/\&/,$what);
 1448: 		       my %hash;
 1449: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
 1450:                            foreach my $pair (@pairs) {
 1451: 			       my ($key,$value)=split(/=/,$pair);
 1452: 			       &ManagePermissions($key, $udom, $uname,
 1453: 						  &GetAuthType( $udom, 
 1454: 								$uname));
 1455:                                $hash{$key}=$value;
 1456:                            }
 1457: 			   if (untie(%hash)) {
 1458:                               print $client "ok\n";
 1459:                            } else {
 1460:                               print $client "error: ".($!+0)
 1461: 				  ." untie(GDBM) Failed ".
 1462:                                       "while attempting rolesput\n";
 1463:                            }
 1464:                        } else {
 1465:                            print $client "error: ".($!+0)
 1466: 			       ." tie(GDBM) Failed ".
 1467:                                    "while attempting rolesput\n";
 1468:                        }
 1469: 		      } else {
 1470:                           print $client "refused\n";
 1471:                       }
 1472: # -------------------------------------------------------------------- rolesdel
 1473:                    } elsif ($userinput =~ /^rolesdel/) {
 1474: 		       &Debug("rolesdel");
 1475: 		    if ($wasenc==1) {
 1476:                        my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
 1477:                           =split(/:/,$userinput);
 1478: 		       &Debug("cmd = ".$cmd." exedom= ".$exedom.
 1479: 				    "user = ".$exeuser." udom=".$udom.
 1480: 				    "what = ".$what);
 1481:                        my $namespace='roles';
 1482:                        chomp($what);
 1483:                        my $proname=propath($udom,$uname);
 1484:                        my $now=time;
 1485:                        {
 1486: 			   my $hfh;
 1487: 			   if (
 1488:                              $hfh=IO::File->new(">>$proname/$namespace.hist")
 1489: 			       ) { 
 1490:                                   print $hfh "D:$now:$exedom:$exeuser:$what\n";
 1491:                                  }
 1492: 		       }
 1493:                        my @rolekeys=split(/\&/,$what);
 1494: 		       my %hash;
 1495: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
 1496:                            foreach my $key (@rolekeys) {
 1497:                                delete $hash{$key};
 1498:                            }
 1499: 			   if (untie(%hash)) {
 1500:                               print $client "ok\n";
 1501:                            } else {
 1502:                               print $client "error: ".($!+0)
 1503: 				  ." untie(GDBM) Failed ".
 1504:                                       "while attempting rolesdel\n";
 1505:                            }
 1506:                        } else {
 1507:                            print $client "error: ".($!+0)
 1508: 			       ." tie(GDBM) Failed ".
 1509:                                    "while attempting rolesdel\n";
 1510:                        }
 1511: 		      } else {
 1512:                           print $client "refused\n";
 1513:                       }
 1514: # ------------------------------------------------------------------------- get
 1515:                    } elsif ($userinput =~ /^get/) {
 1516:                        my ($cmd,$udom,$uname,$namespace,$what)
 1517:                           =split(/:/,$userinput);
 1518:                        $namespace=~s/\//\_/g;
 1519:                        $namespace=~s/\W//g;
 1520:                        chomp($what);
 1521:                        my @queries=split(/\&/,$what);
 1522:                        my $proname=propath($udom,$uname);
 1523:                        my $qresult='';
 1524: 		       my %hash;
 1525: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
 1526:                            for (my $i=0;$i<=$#queries;$i++) {
 1527:                                $qresult.="$hash{$queries[$i]}&";
 1528:                            }
 1529: 			   if (untie(%hash)) {
 1530: 		              $qresult=~s/\&$//;
 1531:                               print $client "$qresult\n";
 1532:                            } else {
 1533:                               print $client "error: ".($!+0)
 1534: 				  ." untie(GDBM) Failed ".
 1535:                                       "while attempting get\n";
 1536:                            }
 1537:                        } else {
 1538:                            if ($!+0 == 2) {
 1539:                                print $client "error:No such file or ".
 1540:                                    "GDBM reported bad block error\n";
 1541:                            } else {
 1542:                                print $client "error: ".($!+0)
 1543:                                    ." tie(GDBM) Failed ".
 1544:                                        "while attempting get\n";
 1545:                            }
 1546:                        }
 1547: # ------------------------------------------------------------------------ eget
 1548:                    } elsif ($userinput =~ /^eget/) {
 1549:                        my ($cmd,$udom,$uname,$namespace,$what)
 1550:                           =split(/:/,$userinput);
 1551:                        $namespace=~s/\//\_/g;
 1552:                        $namespace=~s/\W//g;
 1553:                        chomp($what);
 1554:                        my @queries=split(/\&/,$what);
 1555:                        my $proname=propath($udom,$uname);
 1556:                        my $qresult='';
 1557: 		       my %hash;
 1558: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
 1559:                            for (my $i=0;$i<=$#queries;$i++) {
 1560:                                $qresult.="$hash{$queries[$i]}&";
 1561:                            }
 1562: 			   if (untie(%hash)) {
 1563: 		              $qresult=~s/\&$//;
 1564:                               if ($cipher) {
 1565:                                 my $cmdlength=length($qresult);
 1566:                                 $qresult.="         ";
 1567:                                 my $encqresult='';
 1568:                                 for 
 1569: 				(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
 1570:                                  $encqresult.=
 1571:                                  unpack("H16",
 1572:                                  $cipher->encrypt(substr($qresult,$encidx,8)));
 1573:                                 }
 1574:                                 print $client "enc:$cmdlength:$encqresult\n";
 1575: 			      } else {
 1576: 			        print $client "error:no_key\n";
 1577:                               }
 1578:                            } else {
 1579:                               print $client "error: ".($!+0)
 1580: 				  ." untie(GDBM) Failed ".
 1581:                                       "while attempting eget\n";
 1582:                            }
 1583:                        } else {
 1584:                            print $client "error: ".($!+0)
 1585: 			       ." tie(GDBM) Failed ".
 1586:                                    "while attempting eget\n";
 1587:                        }
 1588: # ------------------------------------------------------------------------- del
 1589:                    } elsif ($userinput =~ /^del/) {
 1590:                        my ($cmd,$udom,$uname,$namespace,$what)
 1591:                           =split(/:/,$userinput);
 1592:                        $namespace=~s/\//\_/g;
 1593:                        $namespace=~s/\W//g;
 1594:                        chomp($what);
 1595:                        my $proname=propath($udom,$uname);
 1596:                        my $now=time;
 1597:                        unless ($namespace=~/^nohist\_/) {
 1598: 			   my $hfh;
 1599: 			   if (
 1600:                              $hfh=IO::File->new(">>$proname/$namespace.hist")
 1601: 			       ) { print $hfh "D:$now:$what\n"; }
 1602: 		       }
 1603:                        my @keys=split(/\&/,$what);
 1604: 		       my %hash;
 1605: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
 1606:                            foreach my $key (@keys) {
 1607:                                delete($hash{$key});
 1608:                            }
 1609: 			   if (untie(%hash)) {
 1610:                               print $client "ok\n";
 1611:                            } else {
 1612:                               print $client "error: ".($!+0)
 1613: 				  ." untie(GDBM) Failed ".
 1614:                                       "while attempting del\n";
 1615:                            }
 1616:                        } else {
 1617:                            print $client "error: ".($!+0)
 1618: 			       ." tie(GDBM) Failed ".
 1619:                                    "while attempting del\n";
 1620:                        }
 1621: # ------------------------------------------------------------------------ keys
 1622:                    } elsif ($userinput =~ /^keys/) {
 1623:                        my ($cmd,$udom,$uname,$namespace)
 1624:                           =split(/:/,$userinput);
 1625:                        $namespace=~s/\//\_/g;
 1626:                        $namespace=~s/\W//g;
 1627:                        my $proname=propath($udom,$uname);
 1628:                        my $qresult='';
 1629: 		       my %hash;
 1630: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
 1631:                            foreach my $key (keys %hash) {
 1632:                                $qresult.="$key&";
 1633:                            }
 1634: 			   if (untie(%hash)) {
 1635: 		              $qresult=~s/\&$//;
 1636:                               print $client "$qresult\n";
 1637:                            } else {
 1638:                               print $client "error: ".($!+0)
 1639: 				  ." untie(GDBM) Failed ".
 1640:                                       "while attempting keys\n";
 1641:                            }
 1642:                        } else {
 1643:                            print $client "error: ".($!+0)
 1644: 			       ." tie(GDBM) Failed ".
 1645:                                    "while attempting keys\n";
 1646:                        }
 1647: # ----------------------------------------------------------------- dumpcurrent
 1648:                    } elsif ($userinput =~ /^currentdump/) {
 1649:                        my ($cmd,$udom,$uname,$namespace)
 1650:                           =split(/:/,$userinput);
 1651:                        $namespace=~s/\//\_/g;
 1652:                        $namespace=~s/\W//g;
 1653:                        my $qresult='';
 1654:                        my $proname=propath($udom,$uname);
 1655: 		       my %hash;
 1656:                        if (tie(%hash,'GDBM_File',
 1657:                                "$proname/$namespace.db",
 1658:                                &GDBM_READER(),0640)) {
 1659:                            # Structure of %data:
 1660:                            # $data{$symb}->{$parameter}=$value;
 1661:                            # $data{$symb}->{'v.'.$parameter}=$version;
 1662:                            # since $parameter will be unescaped, we do not
 1663:                            # have to worry about silly parameter names...
 1664:                            my %data = ();
 1665:                            while (my ($key,$value) = each(%hash)) {
 1666:                               my ($v,$symb,$param) = split(/:/,$key);
 1667:                               next if ($v eq 'version' || $symb eq 'keys');
 1668:                               next if (exists($data{$symb}) && 
 1669:                                        exists($data{$symb}->{$param}) &&
 1670:                                        $data{$symb}->{'v.'.$param} > $v);
 1671:                               $data{$symb}->{$param}=$value;
 1672:                               $data{$symb}->{'v.'.$param}=$v;
 1673:                            }
 1674:                            if (untie(%hash)) {
 1675:                              while (my ($symb,$param_hash) = each(%data)) {
 1676:                                while(my ($param,$value) = each (%$param_hash)){
 1677:                                  next if ($param =~ /^v\./);
 1678:                                  $qresult.=$symb.':'.$param.'='.$value.'&';
 1679:                                }
 1680:                              }
 1681:                              chop($qresult);
 1682:                              print $client "$qresult\n";
 1683:                            } else {
 1684:                              print $client "error: ".($!+0)
 1685: 				 ." untie(GDBM) Failed ".
 1686:                                      "while attempting currentdump\n";
 1687:                            }
 1688:                        } else {
 1689:                            print $client "error: ".($!+0)
 1690: 			       ." tie(GDBM) Failed ".
 1691:                                       "while attempting currentdump\n";
 1692:                        }
 1693: # ------------------------------------------------------------------------ dump
 1694:                    } elsif ($userinput =~ /^dump/) {
 1695:                        my ($cmd,$udom,$uname,$namespace,$regexp)
 1696:                           =split(/:/,$userinput);
 1697:                        $namespace=~s/\//\_/g;
 1698:                        $namespace=~s/\W//g;
 1699:                        if (defined($regexp)) {
 1700:                           $regexp=&unescape($regexp);
 1701: 		       } else {
 1702:                           $regexp='.';
 1703: 		       }
 1704:                        my $qresult='';
 1705:                        my $proname=propath($udom,$uname);
 1706: 		       my %hash;
 1707: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
 1708:                            study($regexp);
 1709:                            while (my ($key,$value) = each(%hash)) {
 1710:                                if ($regexp eq '.') {
 1711:                                    $qresult.=$key.'='.$value.'&';
 1712:                                } else {
 1713:                                    my $unescapeKey = &unescape($key);
 1714:                                    if (eval('$unescapeKey=~/$regexp/')) {
 1715:                                        $qresult.="$key=$value&";
 1716:                                    }
 1717:                                }
 1718:                            }
 1719:                            if (untie(%hash)) {
 1720:                                chop($qresult);
 1721:                                print $client "$qresult\n";
 1722:                            } else {
 1723:                                print $client "error: ".($!+0)
 1724: 				   ." untie(GDBM) Failed ".
 1725:                                        "while attempting dump\n";
 1726:                            }
 1727:                        } else {
 1728:                            print $client "error: ".($!+0)
 1729: 			       ." tie(GDBM) Failed ".
 1730:                                       "while attempting dump\n";
 1731:                        }
 1732: # ----------------------------------------------------------------------- store
 1733:                    } elsif ($userinput =~ /^store/) {
 1734:                       my ($cmd,$udom,$uname,$namespace,$rid,$what)
 1735:                           =split(/:/,$userinput);
 1736:                       $namespace=~s/\//\_/g;
 1737:                       $namespace=~s/\W//g;
 1738:                       if ($namespace ne 'roles') {
 1739:                        chomp($what);
 1740:                        my $proname=propath($udom,$uname);
 1741:                        my $now=time;
 1742:                        unless ($namespace=~/^nohist\_/) {
 1743: 			   my $hfh;
 1744: 			   if (
 1745:                              $hfh=IO::File->new(">>$proname/$namespace.hist")
 1746: 			       ) { print $hfh "P:$now:$rid:$what\n"; }
 1747: 		       }
 1748:                        my @pairs=split(/\&/,$what);
 1749: 		       my %hash;
 1750: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
 1751:                            my @previouskeys=split(/&/,$hash{"keys:$rid"});
 1752:                            my $key;
 1753:                            $hash{"version:$rid"}++;
 1754:                            my $version=$hash{"version:$rid"};
 1755:                            my $allkeys=''; 
 1756:                            foreach my $pair (@pairs) {
 1757: 			       my ($key,$value)=split(/=/,$pair);
 1758:                                $allkeys.=$key.':';
 1759:                                $hash{"$version:$rid:$key"}=$value;
 1760:                            }
 1761:                            $hash{"$version:$rid:timestamp"}=$now;
 1762:                            $allkeys.='timestamp';
 1763:                            $hash{"$version:keys:$rid"}=$allkeys;
 1764: 			   if (untie(%hash)) {
 1765:                               print $client "ok\n";
 1766:                            } else {
 1767:                               print $client "error: ".($!+0)
 1768: 				  ." untie(GDBM) Failed ".
 1769:                                       "while attempting store\n";
 1770:                            }
 1771:                        } else {
 1772:                            print $client "error: ".($!+0)
 1773: 			       ." tie(GDBM) Failed ".
 1774:                                    "while attempting store\n";
 1775:                        }
 1776: 		      } else {
 1777:                           print $client "refused\n";
 1778:                       }
 1779: # --------------------------------------------------------------------- restore
 1780:                    } elsif ($userinput =~ /^restore/) {
 1781:                        my ($cmd,$udom,$uname,$namespace,$rid)
 1782:                           =split(/:/,$userinput);
 1783:                        $namespace=~s/\//\_/g;
 1784:                        $namespace=~s/\W//g;
 1785:                        chomp($rid);
 1786:                        my $proname=propath($udom,$uname);
 1787:                        my $qresult='';
 1788: 		       my %hash;
 1789: 		       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
 1790:                 	   my $version=$hash{"version:$rid"};
 1791:                            $qresult.="version=$version&";
 1792:                            my $scope;
 1793:                            for ($scope=1;$scope<=$version;$scope++) {
 1794: 			      my $vkeys=$hash{"$scope:keys:$rid"};
 1795:                               my @keys=split(/:/,$vkeys);
 1796:                               my $key;
 1797:                               $qresult.="$scope:keys=$vkeys&";
 1798:                               foreach $key (@keys) {
 1799: 	     $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
 1800:                               }                                  
 1801:                            }
 1802: 			   if (untie(%hash)) {
 1803: 		              $qresult=~s/\&$//;
 1804:                               print $client "$qresult\n";
 1805:                            } else {
 1806:                               print $client "error: ".($!+0)
 1807: 				  ." untie(GDBM) Failed ".
 1808:                                       "while attempting restore\n";
 1809:                            }
 1810:                        } else {
 1811:                            print $client "error: ".($!+0)
 1812: 			       ." tie(GDBM) Failed ".
 1813:                                    "while attempting restore\n";
 1814:                        }
 1815: # -------------------------------------------------------------------- chatsend
 1816:                    } elsif ($userinput =~ /^chatsend/) {
 1817:                        my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
 1818:                        &chatadd($cdom,$cnum,$newpost);
 1819:                        print $client "ok\n";
 1820: # -------------------------------------------------------------------- chatretr
 1821:                    } elsif ($userinput =~ /^chatretr/) {
 1822:                        my 
 1823:                         ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
 1824:                        my $reply='';
 1825:                        foreach (&getchat($cdom,$cnum,$udom,$uname)) {
 1826: 			   $reply.=&escape($_).':';
 1827:                        }
 1828:                        $reply=~s/\:$//;
 1829:                        print $client $reply."\n";
 1830: # ------------------------------------------------------------------- querysend
 1831:                    } elsif ($userinput =~ /^querysend/) {
 1832:                        my ($cmd,$query,
 1833: 			   $arg1,$arg2,$arg3)=split(/\:/,$userinput);
 1834: 		       $query=~s/\n*$//g;
 1835: 		       print $client "".
 1836: 			       sqlreply("$hostid{$clientip}\&$query".
 1837: 					"\&$arg1"."\&$arg2"."\&$arg3")."\n";
 1838: # ------------------------------------------------------------------ queryreply
 1839:                    } elsif ($userinput =~ /^queryreply/) {
 1840:                        my ($cmd,$id,$reply)=split(/:/,$userinput); 
 1841: 		       my $store;
 1842:                        my $execdir=$perlvar{'lonDaemons'};
 1843:                        if ($store=IO::File->new(">$execdir/tmp/$id")) {
 1844: 			   $reply=~s/\&/\n/g;
 1845: 			   print $store $reply;
 1846: 			   close $store;
 1847: 			   my $store2=IO::File->new(">$execdir/tmp/$id.end");
 1848: 			   print $store2 "done\n";
 1849: 			   close $store2;
 1850: 			   print $client "ok\n";
 1851: 		       }
 1852: 		       else {
 1853: 			   print $client "error: ".($!+0)
 1854: 			       ." IO::File->new Failed ".
 1855:                                    "while attempting queryreply\n";
 1856: 		       }
 1857: # ----------------------------------------------------------------- courseidput
 1858:                    } elsif ($userinput =~ /^courseidput/) {
 1859:                        my ($cmd,$udom,$what)=split(/:/,$userinput);
 1860:                        chomp($what);
 1861:                        $udom=~s/\W//g;
 1862:                        my $proname=
 1863:                               "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
 1864:                        my $now=time;
 1865:                        my @pairs=split(/\&/,$what);
 1866: 		       my %hash;
 1867: 		       if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
 1868:                            foreach my $pair (@pairs) {
 1869: 			       my ($key,$value)=split(/=/,$pair);
 1870:                                $hash{$key}=$value.':'.$now;
 1871:                            }
 1872: 			   if (untie(%hash)) {
 1873:                               print $client "ok\n";
 1874:                            } else {
 1875:                               print $client "error: ".($!+0)
 1876: 				  ." untie(GDBM) Failed ".
 1877:                                       "while attempting courseidput\n";
 1878:                            }
 1879:                        } else {
 1880:                            print $client "error: ".($!+0)
 1881: 			       ." tie(GDBM) Failed ".
 1882:                                       "while attempting courseidput\n";
 1883:                        }
 1884: # ---------------------------------------------------------------- courseiddump
 1885:                    } elsif ($userinput =~ /^courseiddump/) {
 1886:                        my ($cmd,$udom,$since,$description)
 1887:                           =split(/:/,$userinput);
 1888:                        if (defined($description)) {
 1889:                           $description=&unescape($description);
 1890: 		       } else {
 1891:                           $description='.';
 1892: 		       }
 1893:                        unless (defined($since)) { $since=0; }
 1894:                        my $qresult='';
 1895:                        my $proname=
 1896:                               "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
 1897: 		       my %hash;
 1898: 		       if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
 1899:                            while (my ($key,$value) = each(%hash)) {
 1900:                                my ($descr,$lasttime)=split(/\:/,$value);
 1901:                                if ($lasttime<$since) { next; }
 1902:                                if ($description eq '.') {
 1903:                                    $qresult.=$key.'='.$descr.'&';
 1904:                                } else {
 1905:                                    my $unescapeVal = &unescape($descr);
 1906:                                    if (eval('$unescapeVal=~/$description/i')) {
 1907:                                        $qresult.="$key=$descr&";
 1908:                                    }
 1909:                                }
 1910:                            }
 1911:                            if (untie(%hash)) {
 1912:                                chop($qresult);
 1913:                                print $client "$qresult\n";
 1914:                            } else {
 1915:                                print $client "error: ".($!+0)
 1916: 				   ." untie(GDBM) Failed ".
 1917:                                        "while attempting courseiddump\n";
 1918:                            }
 1919:                        } else {
 1920:                            print $client "error: ".($!+0)
 1921: 			       ." tie(GDBM) Failed ".
 1922:                                       "while attempting courseiddump\n";
 1923:                        }
 1924: # ----------------------------------------------------------------------- idput
 1925:                    } elsif ($userinput =~ /^idput/) {
 1926:                        my ($cmd,$udom,$what)=split(/:/,$userinput);
 1927:                        chomp($what);
 1928:                        $udom=~s/\W//g;
 1929:                        my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
 1930:                        my $now=time;
 1931:                        {
 1932: 			   my $hfh;
 1933: 			   if (
 1934:                              $hfh=IO::File->new(">>$proname.hist")
 1935: 			       ) { print $hfh "P:$now:$what\n"; }
 1936: 		       }
 1937:                        my @pairs=split(/\&/,$what);
 1938: 		       my %hash;
 1939: 		       if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
 1940:                            foreach my $pair (@pairs) {
 1941: 			       my ($key,$value)=split(/=/,$pair);
 1942:                                $hash{$key}=$value;
 1943:                            }
 1944: 			   if (untie(%hash)) {
 1945:                               print $client "ok\n";
 1946:                            } else {
 1947:                               print $client "error: ".($!+0)
 1948: 				  ." untie(GDBM) Failed ".
 1949:                                       "while attempting idput\n";
 1950:                            }
 1951:                        } else {
 1952:                            print $client "error: ".($!+0)
 1953: 			       ." tie(GDBM) Failed ".
 1954:                                       "while attempting idput\n";
 1955:                        }
 1956: # ----------------------------------------------------------------------- idget
 1957:                    } elsif ($userinput =~ /^idget/) {
 1958:                        my ($cmd,$udom,$what)=split(/:/,$userinput);
 1959:                        chomp($what);
 1960:                        $udom=~s/\W//g;
 1961:                        my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
 1962:                        my @queries=split(/\&/,$what);
 1963:                        my $qresult='';
 1964: 		       my %hash;
 1965: 		       if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
 1966:                            for (my $i=0;$i<=$#queries;$i++) {
 1967:                                $qresult.="$hash{$queries[$i]}&";
 1968:                            }
 1969: 			   if (untie(%hash)) {
 1970: 			       $qresult=~s/\&$//;
 1971: 			       print $client "$qresult\n";
 1972:                            } else {
 1973: 			       print $client "error: ".($!+0)
 1974: 				   ." untie(GDBM) Failed ".
 1975: 				       "while attempting idget\n";
 1976:                            }
 1977:                        } else {
 1978:                            print $client "error: ".($!+0)
 1979: 			       ." tie(GDBM) Failed ".
 1980:                                    "while attempting idget\n";
 1981:                        }
 1982: # ---------------------------------------------------------------------- tmpput
 1983:                    } elsif ($userinput =~ /^tmpput/) {
 1984:                        my ($cmd,$what)=split(/:/,$userinput);
 1985: 		       my $store;
 1986:                        $tmpsnum++;
 1987:                        my $id=$$.'_'.$clientip.'_'.$tmpsnum;
 1988:                        $id=~s/\W/\_/g;
 1989:                        $what=~s/\n//g;
 1990:                        my $execdir=$perlvar{'lonDaemons'};
 1991:                        if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
 1992: 			   print $store $what;
 1993: 			   close $store;
 1994: 			   print $client "$id\n";
 1995: 		       }
 1996: 		       else {
 1997: 			   print $client "error: ".($!+0)
 1998: 			       ."IO::File->new Failed ".
 1999:                                    "while attempting tmpput\n";
 2000: 		       }
 2001: 
 2002: # ---------------------------------------------------------------------- tmpget
 2003:                    } elsif ($userinput =~ /^tmpget/) {
 2004:                        my ($cmd,$id)=split(/:/,$userinput);
 2005:                        chomp($id);
 2006:                        $id=~s/\W/\_/g;
 2007:                        my $store;
 2008:                        my $execdir=$perlvar{'lonDaemons'};
 2009:                        if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
 2010:                            my $reply=<$store>;
 2011: 			   print $client "$reply\n";
 2012:                            close $store;
 2013: 		       }
 2014: 		       else {
 2015: 			   print $client "error: ".($!+0)
 2016: 			       ."IO::File->new Failed ".
 2017:                                    "while attempting tmpget\n";
 2018: 		       }
 2019: 
 2020: # ---------------------------------------------------------------------- tmpdel
 2021:                    } elsif ($userinput =~ /^tmpdel/) {
 2022:                        my ($cmd,$id)=split(/:/,$userinput);
 2023:                        chomp($id);
 2024:                        $id=~s/\W/\_/g;
 2025:                        my $execdir=$perlvar{'lonDaemons'};
 2026:                        if (unlink("$execdir/tmp/$id.tmp")) {
 2027: 			   print $client "ok\n";
 2028: 		       } else {
 2029: 			   print $client "error: ".($!+0)
 2030: 			       ."Unlink tmp Failed ".
 2031:                                    "while attempting tmpdel\n";
 2032: 		       }
 2033: # -------------------------------------------------------------------------- ls
 2034:                    } elsif ($userinput =~ /^ls/) {
 2035:                        my ($cmd,$ulsdir)=split(/:/,$userinput);
 2036:                        my $ulsout='';
 2037:                        my $ulsfn;
 2038:                        if (-e $ulsdir) {
 2039:                            if(-d $ulsdir) {
 2040:                                if (opendir(LSDIR,$ulsdir)) {
 2041:                                    while ($ulsfn=readdir(LSDIR)) {
 2042:                                        my @ulsstats=stat($ulsdir.'/'.$ulsfn);
 2043:                                        $ulsout.=$ulsfn.'&'.
 2044:                                                 join('&',@ulsstats).':';
 2045:                                    }
 2046:                                    closedir(LSDIR);
 2047:                                }
 2048:                            } else {
 2049:                                my @ulsstats=stat($ulsdir);
 2050:                                $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
 2051:                            }
 2052:                        } else {
 2053:                           $ulsout='no_such_dir';
 2054:                        }
 2055:                        if ($ulsout eq '') { $ulsout='empty'; }
 2056:                        print $client "$ulsout\n";
 2057: # ----------------------------------------------------------------- setannounce
 2058:                    } elsif ($userinput =~ /^setannounce/) {
 2059: 		       my ($cmd,$announcement)=split(/:/,$userinput);
 2060: 		       chomp($announcement);
 2061: 		       $announcement=&unescape($announcement);
 2062:                        if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
 2063: 						'/announcement.txt')) {
 2064: 			   print $store $announcement;
 2065:                            close $store;
 2066: 			   print $client "ok\n";
 2067: 		       } else {
 2068: 			   print $client "error: ".($!+0)."\n";
 2069: 		       }
 2070: # ------------------------------------------------------------------ Hanging up
 2071:                    } elsif (($userinput =~ /^exit/) ||
 2072:                             ($userinput =~ /^init/)) {
 2073:                        &logthis(
 2074:       "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
 2075:                        print $client "bye\n";
 2076:                        $client->close();
 2077: 		       last;
 2078: # ------------------------------------------------------------- unknown command
 2079: 		   } elsif ($userinput =~ /^sethost:/) {
 2080: 		       print $client &sethost($userinput)."\n";
 2081: 		   } elsif ($userinput =~/^version:/) {
 2082: 		       print $client &version($userinput)."\n";
 2083:                    } else {
 2084:                        # unknown command
 2085:                        print $client "unknown_cmd\n";
 2086:                    }
 2087: # -------------------------------------------------------------------- complete
 2088: 		   alarm(0);
 2089:                    &status('Listening to '.$hostid{$clientip});
 2090: 	       }
 2091: # --------------------------------------------- client unknown or fishy, refuse
 2092:             } else {
 2093: 	        print $client "refused\n";
 2094:                 $client->close();
 2095:                 &logthis("<font color=blue>WARNING: "
 2096:                 ."Rejected client $clientip, closing connection</font>");
 2097:             }
 2098: 	}             
 2099: 
 2100: # =============================================================================
 2101:        
 2102: 	&logthis("<font color=red>CRITICAL: "
 2103: 		 ."Disconnect from $clientip ($hostid{$clientip})</font>");    
 2104: 
 2105: 
 2106:         # this exit is VERY important, otherwise the child will become
 2107:         # a producer of more and more children, forking yourself into
 2108:         # process death.
 2109:         exit;
 2110:     
 2111: }
 2112: 
 2113: 
 2114: #
 2115: #   Checks to see if the input roleput request was to set
 2116: # an author role.  If so, invokes the lchtmldir script to set
 2117: # up a correct public_html 
 2118: # Parameters:
 2119: #    request   - The request sent to the rolesput subchunk.
 2120: #                We're looking for  /domain/_au
 2121: #    domain    - The domain in which the user is having roles doctored.
 2122: #    user      - Name of the user for which the role is being put.
 2123: #    authtype  - The authentication type associated with the user.
 2124: #
 2125: sub ManagePermissions
 2126: {
 2127:     my $request = shift;
 2128:     my $domain  = shift;
 2129:     my $user    = shift;
 2130:     my $authtype= shift;
 2131: 
 2132:     # See if the request is of the form /$domain/_au
 2133:     &logthis("ruequest is $request");
 2134:     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
 2135: 	my $execdir = $perlvar{'lonDaemons'};
 2136: 	my $userhome= "/home/$user" ;
 2137: 	&logthis("system $execdir/lchtmldir $userhome $user $authtype");
 2138: 	system("$execdir/lchtmldir $userhome $user $authtype");
 2139:     }
 2140: }
 2141: #
 2142: #   GetAuthType - Determines the authorization type of a user in a domain.
 2143: 
 2144: #     Returns the authorization type or nouser if there is no such user.
 2145: #
 2146: sub GetAuthType 
 2147: {
 2148:     my $domain = shift;
 2149:     my $user   = shift;
 2150: 
 2151:     Debug("GetAuthType( $domain, $user ) \n");
 2152:     my $proname    = &propath($domain, $user); 
 2153:     my $passwdfile = "$proname/passwd";
 2154:     if( -e $passwdfile ) {
 2155: 	my $pf = IO::File->new($passwdfile);
 2156: 	my $realpassword = <$pf>;
 2157: 	chomp($realpassword);
 2158: 	Debug("Password info = $realpassword\n");
 2159: 	my ($authtype, $contentpwd) = split(/:/, $realpassword);
 2160: 	Debug("Authtype = $authtype, content = $contentpwd\n");
 2161: 	my $availinfo = '';
 2162: 	if($authtype eq 'krb4' or $authtype eq 'krb5') {
 2163: 	    $availinfo = $contentpwd;
 2164: 	}
 2165: 
 2166: 	return "$authtype:$availinfo";
 2167:     }
 2168:     else {
 2169: 	Debug("Returning nouser");
 2170: 	return "nouser";
 2171:     }
 2172: }
 2173: 
 2174: sub addline {
 2175:     my ($fname,$hostid,$ip,$newline)=@_;
 2176:     my $contents;
 2177:     my $found=0;
 2178:     my $expr='^'.$hostid.':'.$ip.':';
 2179:     $expr =~ s/\./\\\./g;
 2180:     my $sh;
 2181:     if ($sh=IO::File->new("$fname.subscription")) {
 2182: 	while (my $subline=<$sh>) {
 2183: 	    if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
 2184: 	}
 2185: 	$sh->close();
 2186:     }
 2187:     $sh=IO::File->new(">$fname.subscription");
 2188:     if ($contents) { print $sh $contents; }
 2189:     if ($newline) { print $sh $newline; }
 2190:     $sh->close();
 2191:     return $found;
 2192: }
 2193: 
 2194: sub getchat {
 2195:     my ($cdom,$cname,$udom,$uname)=@_;
 2196:     my %hash;
 2197:     my $proname=&propath($cdom,$cname);
 2198:     my @entries=();
 2199:     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
 2200: 	    &GDBM_READER(),0640)) {
 2201: 	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
 2202: 	untie %hash;
 2203:     }
 2204:     my @participants=();
 2205:     my $cutoff=time-60;
 2206:     if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
 2207: 	    &GDBM_WRCREAT(),0640)) {
 2208:         $hash{$uname.':'.$udom}=time;
 2209:         foreach (sort keys %hash) {
 2210: 	    if ($hash{$_}>$cutoff) {
 2211: 		$participants[$#participants+1]='active_participant:'.$_;
 2212:             }
 2213:         }
 2214:         untie %hash;
 2215:     }
 2216:     return (@participants,@entries);
 2217: }
 2218: 
 2219: sub chatadd {
 2220:     my ($cdom,$cname,$newchat)=@_;
 2221:     my %hash;
 2222:     my $proname=&propath($cdom,$cname);
 2223:     my @entries=();
 2224:     my $time=time;
 2225:     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
 2226: 	    &GDBM_WRCREAT(),0640)) {
 2227: 	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
 2228: 	my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
 2229: 	my ($thentime,$idnum)=split(/\_/,$lastid);
 2230: 	my $newid=$time.'_000000';
 2231: 	if ($thentime==$time) {
 2232: 	    $idnum=~s/^0+//;
 2233: 	    $idnum++;
 2234: 	    $idnum=substr('000000'.$idnum,-6,6);
 2235: 	    $newid=$time.'_'.$idnum;
 2236: 	}
 2237: 	$hash{$newid}=$newchat;
 2238: 	my $expired=$time-3600;
 2239: 	foreach (keys %hash) {
 2240: 	    my ($thistime)=($_=~/(\d+)\_/);
 2241: 	    if ($thistime<$expired) {
 2242: 		delete $hash{$_};
 2243: 	    }
 2244: 	}
 2245: 	untie %hash;
 2246:     }
 2247:     {
 2248: 	my $hfh;
 2249: 	if ($hfh=IO::File->new(">>$proname/chatroom.log")) { 
 2250: 	    print $hfh "$time:".&unescape($newchat)."\n";
 2251: 	}
 2252:     }
 2253: }
 2254: 
 2255: sub unsub {
 2256:     my ($fname,$clientip)=@_;
 2257:     my $result;
 2258:     if (unlink("$fname.$hostid{$clientip}")) {
 2259: 	$result="ok\n";
 2260:     } else {
 2261: 	$result="not_subscribed\n";
 2262:     }
 2263:     if (-e "$fname.subscription") {
 2264: 	my $found=&addline($fname,$hostid{$clientip},$clientip,'');
 2265: 	if ($found) { $result="ok\n"; }
 2266:     } else {
 2267: 	if ($result != "ok\n") { $result="not_subscribed\n"; }
 2268:     }
 2269:     return $result;
 2270: }
 2271: 
 2272: sub currentversion {
 2273:     my $fname=shift;
 2274:     my $version=-1;
 2275:     my $ulsdir='';
 2276:     if ($fname=~/^(.+)\/[^\/]+$/) {
 2277:        $ulsdir=$1;
 2278:     }
 2279:     my ($fnamere1,$fnamere2);
 2280:     # remove version if already specified
 2281:     $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
 2282:     # get the bits that go before and after the version number
 2283:     if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
 2284: 	$fnamere1=$1;
 2285: 	$fnamere2='.'.$2;
 2286:     }
 2287:     if (-e $fname) { $version=1; }
 2288:     if (-e $ulsdir) {
 2289: 	if(-d $ulsdir) {
 2290: 	    if (opendir(LSDIR,$ulsdir)) {
 2291: 		my $ulsfn;
 2292: 		while ($ulsfn=readdir(LSDIR)) {
 2293: # see if this is a regular file (ignore links produced earlier)
 2294: 		    my $thisfile=$ulsdir.'/'.$ulsfn;
 2295: 		    unless (-l $thisfile) {
 2296: 			if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
 2297: 			    if ($1>$version) { $version=$1; }
 2298: 			}
 2299: 		    }
 2300: 		}
 2301: 		closedir(LSDIR);
 2302: 		$version++;
 2303: 	    }
 2304: 	}
 2305:     }
 2306:     return $version;
 2307: }
 2308: 
 2309: sub thisversion {
 2310:     my $fname=shift;
 2311:     my $version=-1;
 2312:     if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
 2313: 	$version=$1;
 2314:     }
 2315:     return $version;
 2316: }
 2317: 
 2318: sub subscribe {
 2319:     my ($userinput,$clientip)=@_;
 2320:     my $result;
 2321:     my ($cmd,$fname)=split(/:/,$userinput);
 2322:     my $ownership=&ishome($fname);
 2323:     if ($ownership eq 'owner') {
 2324: # explitly asking for the current version?
 2325:         unless (-e $fname) {
 2326:             my $currentversion=&currentversion($fname);
 2327: 	    if (&thisversion($fname)==$currentversion) {
 2328:                 if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
 2329: 		    my $root=$1;
 2330:                     my $extension=$2;
 2331:                     symlink($root.'.'.$extension,
 2332:                             $root.'.'.$currentversion.'.'.$extension);
 2333:                     unless ($extension=~/\.meta$/) {
 2334:                        symlink($root.'.'.$extension.'.meta',
 2335:                             $root.'.'.$currentversion.'.'.$extension.'.meta');
 2336: 		    }
 2337:                 }
 2338:             }
 2339:         }
 2340: 	if (-e $fname) {
 2341: 	    if (-d $fname) {
 2342: 		$result="directory\n";
 2343: 	    } else {
 2344: 		if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
 2345: 		my $now=time;
 2346: 		my $found=&addline($fname,$hostid{$clientip},$clientip,
 2347: 				   "$hostid{$clientip}:$clientip:$now\n");
 2348: 		if ($found) { $result="$fname\n"; }
 2349: 		# if they were subscribed to only meta data, delete that
 2350:                 # subscription, when you subscribe to a file you also get
 2351:                 # the metadata
 2352: 		unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
 2353: 		$fname=~s/\/home\/httpd\/html\/res/raw/;
 2354: 		$fname="http://$thisserver/".$fname;
 2355: 		$result="$fname\n";
 2356: 	    }
 2357: 	} else {
 2358: 	    $result="not_found\n";
 2359: 	}
 2360:     } else {
 2361: 	$result="rejected\n";
 2362:     }
 2363:     return $result;
 2364: }
 2365: 
 2366: sub make_passwd_file {
 2367:     my ($uname, $umode,$npass,$passfilename)=@_;
 2368:     my $result="ok\n";
 2369:     if ($umode eq 'krb4' or $umode eq 'krb5') {
 2370: 	{
 2371: 	    my $pf = IO::File->new(">$passfilename");
 2372: 	    print $pf "$umode:$npass\n";
 2373: 	}
 2374:     } elsif ($umode eq 'internal') {
 2375: 	my $salt=time;
 2376: 	$salt=substr($salt,6,2);
 2377: 	my $ncpass=crypt($npass,$salt);
 2378: 	{
 2379: 	    &Debug("Creating internal auth");
 2380: 	    my $pf = IO::File->new(">$passfilename");
 2381: 	    print $pf "internal:$ncpass\n"; 
 2382: 	}
 2383:     } elsif ($umode eq 'localauth') {
 2384: 	{
 2385: 	    my $pf = IO::File->new(">$passfilename");
 2386: 	    print $pf "localauth:$npass\n";
 2387: 	}
 2388:     } elsif ($umode eq 'unix') {
 2389: 	{
 2390: 	    my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
 2391: 	    {
 2392: 		&Debug("Executing external: ".$execpath);
 2393: 		&Debug("user  = ".$uname.", Password =". $npass);
 2394: 		my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
 2395: 		print $se "$uname\n";
 2396: 		print $se "$npass\n";
 2397: 		print $se "$npass\n";
 2398: 	    }
 2399: 	    my $useraddok = $?;
 2400: 	    if($useraddok > 0) {
 2401: 		&logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
 2402: 	    }
 2403: 	    my $pf = IO::File->new(">$passfilename");
 2404: 	    print $pf "unix:\n";
 2405: 	}
 2406:     } elsif ($umode eq 'none') {
 2407: 	{
 2408: 	    my $pf = IO::File->new(">$passfilename");
 2409: 	    print $pf "none:\n";
 2410: 	}
 2411:     } else {
 2412: 	$result="auth_mode_error\n";
 2413:     }
 2414:     return $result;
 2415: }
 2416: 
 2417: sub sethost {
 2418:     my ($remotereq) = @_;
 2419:     my (undef,$hostid)=split(/:/,$remotereq);
 2420:     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
 2421:     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
 2422: 	$currenthostid=$hostid;
 2423: 	$currentdomainid=$hostdom{$hostid};
 2424: 	&logthis("Setting hostid to $hostid, and domain to $currentdomainid");
 2425:     } else {
 2426: 	&logthis("Requested host id $hostid not an alias of ".
 2427: 		 $perlvar{'lonHostID'}." refusing connection");
 2428: 	return 'unable_to_set';
 2429:     }
 2430:     return 'ok';
 2431: }
 2432: 
 2433: sub version {
 2434:     my ($userinput)=@_;
 2435:     $remoteVERSION=(split(/:/,$userinput))[1];
 2436:     return "version:$VERSION";
 2437: }
 2438: 
 2439: #There is a copy of this in lonnet.pm
 2440: sub userload {
 2441:     my $numusers=0;
 2442:     {
 2443: 	opendir(LONIDS,$perlvar{'lonIDsDir'});
 2444: 	my $filename;
 2445: 	my $curtime=time;
 2446: 	while ($filename=readdir(LONIDS)) {
 2447: 	    if ($filename eq '.' || $filename eq '..') {next;}
 2448: 	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
 2449: 	    if ($curtime-$mtime < 3600) { $numusers++; }
 2450: 	}
 2451: 	closedir(LONIDS);
 2452:     }
 2453:     my $userloadpercent=0;
 2454:     my $maxuserload=$perlvar{'lonUserLoadLim'};
 2455:     if ($maxuserload) {
 2456: 	$userloadpercent=100*$numusers/$maxuserload;
 2457:     }
 2458:     $userloadpercent=sprintf("%.2f",$userloadpercent);
 2459:     return $userloadpercent;
 2460: }
 2461: 
 2462: # ----------------------------------- POD (plain old documentation, CPAN style)
 2463: 
 2464: =head1 NAME
 2465: 
 2466: lond - "LON Daemon" Server (port "LOND" 5663)
 2467: 
 2468: =head1 SYNOPSIS
 2469: 
 2470: Usage: B<lond>
 2471: 
 2472: Should only be run as user=www.  This is a command-line script which
 2473: is invoked by B<loncron>.  There is no expectation that a typical user
 2474: will manually start B<lond> from the command-line.  (In other words,
 2475: DO NOT START B<lond> YOURSELF.)
 2476: 
 2477: =head1 DESCRIPTION
 2478: 
 2479: There are two characteristics associated with the running of B<lond>,
 2480: PROCESS MANAGEMENT (starting, stopping, handling child processes)
 2481: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
 2482: subscriptions, etc).  These are described in two large
 2483: sections below.
 2484: 
 2485: B<PROCESS MANAGEMENT>
 2486: 
 2487: Preforker - server who forks first. Runs as a daemon. HUPs.
 2488: Uses IDEA encryption
 2489: 
 2490: B<lond> forks off children processes that correspond to the other servers
 2491: in the network.  Management of these processes can be done at the
 2492: parent process level or the child process level.
 2493: 
 2494: B<logs/lond.log> is the location of log messages.
 2495: 
 2496: The process management is now explained in terms of linux shell commands,
 2497: subroutines internal to this code, and signal assignments:
 2498: 
 2499: =over 4
 2500: 
 2501: =item *
 2502: 
 2503: PID is stored in B<logs/lond.pid>
 2504: 
 2505: This is the process id number of the parent B<lond> process.
 2506: 
 2507: =item *
 2508: 
 2509: SIGTERM and SIGINT
 2510: 
 2511: Parent signal assignment:
 2512:  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
 2513: 
 2514: Child signal assignment:
 2515:  $SIG{INT}  = 'DEFAULT'; (and SIGTERM is DEFAULT also)
 2516: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
 2517:  to restart a new child.)
 2518: 
 2519: Command-line invocations:
 2520:  B<kill> B<-s> SIGTERM I<PID>
 2521:  B<kill> B<-s> SIGINT I<PID>
 2522: 
 2523: Subroutine B<HUNTSMAN>:
 2524:  This is only invoked for the B<lond> parent I<PID>.
 2525: This kills all the children, and then the parent.
 2526: The B<lonc.pid> file is cleared.
 2527: 
 2528: =item *
 2529: 
 2530: SIGHUP
 2531: 
 2532: Current bug:
 2533:  This signal can only be processed the first time
 2534: on the parent process.  Subsequent SIGHUP signals
 2535: have no effect.
 2536: 
 2537: Parent signal assignment:
 2538:  $SIG{HUP}  = \&HUPSMAN;
 2539: 
 2540: Child signal assignment:
 2541:  none (nothing happens)
 2542: 
 2543: Command-line invocations:
 2544:  B<kill> B<-s> SIGHUP I<PID>
 2545: 
 2546: Subroutine B<HUPSMAN>:
 2547:  This is only invoked for the B<lond> parent I<PID>,
 2548: This kills all the children, and then the parent.
 2549: The B<lond.pid> file is cleared.
 2550: 
 2551: =item *
 2552: 
 2553: SIGUSR1
 2554: 
 2555: Parent signal assignment:
 2556:  $SIG{USR1} = \&USRMAN;
 2557: 
 2558: Child signal assignment:
 2559:  $SIG{USR1}= \&logstatus;
 2560: 
 2561: Command-line invocations:
 2562:  B<kill> B<-s> SIGUSR1 I<PID>
 2563: 
 2564: Subroutine B<USRMAN>:
 2565:  When invoked for the B<lond> parent I<PID>,
 2566: SIGUSR1 is sent to all the children, and the status of
 2567: each connection is logged.
 2568: 
 2569: =item *
 2570: 
 2571: SIGUSR2
 2572: 
 2573: Parent Signal assignment:
 2574:     $SIG{USR2} = \&UpdateHosts
 2575: 
 2576: Child signal assignment:
 2577:     NONE
 2578: 
 2579: 
 2580: =item *
 2581: 
 2582: SIGCHLD
 2583: 
 2584: Parent signal assignment:
 2585:  $SIG{CHLD} = \&REAPER;
 2586: 
 2587: Child signal assignment:
 2588:  none
 2589: 
 2590: Command-line invocations:
 2591:  B<kill> B<-s> SIGCHLD I<PID>
 2592: 
 2593: Subroutine B<REAPER>:
 2594:  This is only invoked for the B<lond> parent I<PID>.
 2595: Information pertaining to the child is removed.
 2596: The socket port is cleaned up.
 2597: 
 2598: =back
 2599: 
 2600: B<SERVER-SIDE ACTIVITIES>
 2601: 
 2602: Server-side information can be accepted in an encrypted or non-encrypted
 2603: method.
 2604: 
 2605: =over 4
 2606: 
 2607: =item ping
 2608: 
 2609: Query a client in the hosts.tab table; "Are you there?"
 2610: 
 2611: =item pong
 2612: 
 2613: Respond to a ping query.
 2614: 
 2615: =item ekey
 2616: 
 2617: Read in encrypted key, make cipher.  Respond with a buildkey.
 2618: 
 2619: =item load
 2620: 
 2621: Respond with CPU load based on a computation upon /proc/loadavg.
 2622: 
 2623: =item currentauth
 2624: 
 2625: Reply with current authentication information (only over an
 2626: encrypted channel).
 2627: 
 2628: =item auth
 2629: 
 2630: Only over an encrypted channel, reply as to whether a user's
 2631: authentication information can be validated.
 2632: 
 2633: =item passwd
 2634: 
 2635: Allow for a password to be set.
 2636: 
 2637: =item makeuser
 2638: 
 2639: Make a user.
 2640: 
 2641: =item passwd
 2642: 
 2643: Allow for authentication mechanism and password to be changed.
 2644: 
 2645: =item home
 2646: 
 2647: Respond to a question "are you the home for a given user?"
 2648: 
 2649: =item update
 2650: 
 2651: Update contents of a subscribed resource.
 2652: 
 2653: =item unsubscribe
 2654: 
 2655: The server is unsubscribing from a resource.
 2656: 
 2657: =item subscribe
 2658: 
 2659: The server is subscribing to a resource.
 2660: 
 2661: =item log
 2662: 
 2663: Place in B<logs/lond.log>
 2664: 
 2665: =item put
 2666: 
 2667: stores hash in namespace
 2668: 
 2669: =item rolesput
 2670: 
 2671: put a role into a user's environment
 2672: 
 2673: =item get
 2674: 
 2675: returns hash with keys from array
 2676: reference filled in from namespace
 2677: 
 2678: =item eget
 2679: 
 2680: returns hash with keys from array
 2681: reference filled in from namesp (encrypts the return communication)
 2682: 
 2683: =item rolesget
 2684: 
 2685: get a role from a user's environment
 2686: 
 2687: =item del
 2688: 
 2689: deletes keys out of array from namespace
 2690: 
 2691: =item keys
 2692: 
 2693: returns namespace keys
 2694: 
 2695: =item dump
 2696: 
 2697: dumps the complete (or key matching regexp) namespace into a hash
 2698: 
 2699: =item store
 2700: 
 2701: stores hash permanently
 2702: for this url; hashref needs to be given and should be a \%hashname; the
 2703: remaining args aren't required and if they aren't passed or are '' they will
 2704: be derived from the ENV
 2705: 
 2706: =item restore
 2707: 
 2708: returns a hash for a given url
 2709: 
 2710: =item querysend
 2711: 
 2712: Tells client about the lonsql process that has been launched in response
 2713: to a sent query.
 2714: 
 2715: =item queryreply
 2716: 
 2717: Accept information from lonsql and make appropriate storage in temporary
 2718: file space.
 2719: 
 2720: =item idput
 2721: 
 2722: Defines usernames as corresponding to IDs.  (These "IDs" are unique identifiers
 2723: for each student, defined perhaps by the institutional Registrar.)
 2724: 
 2725: =item idget
 2726: 
 2727: Returns usernames corresponding to IDs.  (These "IDs" are unique identifiers
 2728: for each student, defined perhaps by the institutional Registrar.)
 2729: 
 2730: =item tmpput
 2731: 
 2732: Accept and store information in temporary space.
 2733: 
 2734: =item tmpget
 2735: 
 2736: Send along temporarily stored information.
 2737: 
 2738: =item ls
 2739: 
 2740: List part of a user's directory.
 2741: 
 2742: =item pushtable
 2743: 
 2744: Pushes a file in /home/httpd/lonTab directory.  Currently limited to:
 2745: hosts.tab and domain.tab. The old file is copied to  *.tab.backup but
 2746: must be restored manually in case of a problem with the new table file.
 2747: pushtable requires that the request be encrypted and validated via
 2748: ValidateManager.  The form of the command is:
 2749: enc:pushtable tablename <tablecontents> \n
 2750: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a 
 2751: cleartext newline.
 2752: 
 2753: =item Hanging up (exit or init)
 2754: 
 2755: What to do when a client tells the server that they (the client)
 2756: are leaving the network.
 2757: 
 2758: =item unknown command
 2759: 
 2760: If B<lond> is sent an unknown command (not in the list above),
 2761: it replys to the client "unknown_cmd".
 2762: 
 2763: 
 2764: =item UNKNOWN CLIENT
 2765: 
 2766: If the anti-spoofing algorithm cannot verify the client,
 2767: the client is rejected (with a "refused" message sent
 2768: to the client, and the connection is closed.
 2769: 
 2770: =back
 2771: 
 2772: =head1 PREREQUISITES
 2773: 
 2774: IO::Socket
 2775: IO::File
 2776: Apache::File
 2777: Symbol
 2778: POSIX
 2779: Crypt::IDEA
 2780: LWP::UserAgent()
 2781: GDBM_File
 2782: Authen::Krb4
 2783: Authen::Krb5
 2784: 
 2785: =head1 COREQUISITES
 2786: 
 2787: =head1 OSNAMES
 2788: 
 2789: linux
 2790: 
 2791: =head1 SCRIPT CATEGORIES
 2792: 
 2793: Server/Process
 2794: 
 2795: =cut

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