File:  [LON-CAPA] / loncom / lond
Revision 1.140: download - view: text, annotated - select for diffs
Tue Aug 26 11:15:57 2003 UTC (21 years, 2 months ago) by foxr
Branches: MAIN
CVS tags: HEAD
Added infrastructure for validating management requests... based on
loncapa host id.  In the present testing version, a host is authenticated as
a manager if it is a valid member of the cluster.  This will, of course, change
soon.

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

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