loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.230: download - view: text, annotated - select for diffs
Mon Aug 16 11:44:10 2004 UTC (19 years, 8 months ago) by foxr
Branches: MAIN
CVS tags: HEAD

Added handler based request processors for the following:
- subscribe
- currentversion
- log
- put
- inc
- rolesput

Also did a little stylelistic work (a very little... namely rename
ManagePermissions -> manage_permissions and ensure that it was
called as &manage_permissions... thank heavens for global search
and destroy.

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