loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.223: download - view: text, annotated - select for diffs
Thu Aug 5 11:37:05 2004 UTC (19 years, 9 months ago) by foxr
Branches: MAIN
CVS tags: HEAD

Modifed usage of lcuseradd to tell it to log exit status codes in a file,
we then read/unlink the file and can now correctly report lcuseradd
failures to the client.  This allows the cuser to indicate that
changing the passwd on a filesystem authenticated user really does fail
rather than work...the message, however may not be so obvious
(lcuseradd_failed:User already exists), since the wrong lond request is
getting invoked ultimately by the UI (Filed a bug on this).  The
user will be astonished: Of course the user exists you idiotic computer,
that's why I'm trying to change the password!!

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