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