loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.224: download - view: text, annotated - select for diffs
Fri Aug 6 10:27:53 2004 UTC (19 years, 9 months ago) by foxr
Branches: MAIN
CVS tags: HEAD

1. Use the 'standard' loncapa tmp directory for lcuseradd files.
2. Raise the self esteem of all the else's by cuddling them in accordance
  with LonCAPA coding style.

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