loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.239: download - view: text, annotated - select for diffs
Tue Aug 24 10:59:50 2004 UTC (19 years, 8 months ago) by foxr
Branches: MAIN
CVS tags: HEAD

- Turn off DEBUG so others won't get annoyed.
- Merge in changes to the Josh-ls request processing to a new
  handlerized ls request processor.
- Remove all the old code that used to do the
  idput, idget, tmpput, tmpget, tmpdel, and ls request
  processing since those have been handlerized.

1: #!/usr/bin/perl 2: # The LearningOnline Network 3: # lond "LON Daemon" Server (port "LOND" 5663) 4: # 5: # $Id: lond,v 1.239 2004/08/24 10:59:50 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.239 $'; #' 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: 1288: # 1289: # ls - list the contents of a directory. For each file in the 1290: # selected directory the filename followed by the full output of 1291: # the stat function is returned. The returned info for each 1292: # file are separated by ':'. The stat fields are separated by &'s. 1293: # Parameters: 1294: # $cmd - The command that dispatched us (ls). 1295: # $ulsdir - The directory path to list... I'm not sure what this 1296: # is relative as things like ls:. return e.g. 1297: # no_such_dir. 1298: # $client - Socket open on the client. 1299: # Returns: 1300: # 1 - indicating that the daemon should not disconnect. 1301: # Side Effects: 1302: # The reply is written to $client. 1303: # 1304: sub ls_handler { 1305: my ($cmd, $ulsdir, $client) = @_; 1306: 1307: my $userinput = "$cmd:$ulsdir"; 1308: 1309: my $obs; 1310: my $rights; 1311: my $ulsout=''; 1312: my $ulsfn; 1313: if (-e $ulsdir) { 1314: if(-d $ulsdir) { 1315: if (opendir(LSDIR,$ulsdir)) { 1316: while ($ulsfn=readdir(LSDIR)) { 1317: undef $obs, $rights; 1318: my @ulsstats=stat($ulsdir.'/'.$ulsfn); 1319: #We do some obsolete checking here 1320: if(-e $ulsdir.'/'.$ulsfn.".meta") { 1321: open(FILE, $ulsdir.'/'.$ulsfn.".meta"); 1322: my @obsolete=<FILE>; 1323: foreach my $obsolete (@obsolete) { 1324: if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } 1325: if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; } 1326: } 1327: } 1328: $ulsout.=$ulsfn.'&'.join('&',@ulsstats); 1329: if($obs eq '1') { $ulsout.="&1"; } 1330: else { $ulsout.="&0"; } 1331: if($rights eq '1') { $ulsout.="&1:"; } 1332: else { $ulsout.="&0:"; } 1333: } 1334: closedir(LSDIR); 1335: } 1336: } else { 1337: my @ulsstats=stat($ulsdir); 1338: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; 1339: } 1340: } else { 1341: $ulsout='no_such_dir'; 1342: } 1343: if ($ulsout eq '') { $ulsout='empty'; } 1344: print $client "$ulsout\n"; 1345: 1346: return 1; 1347: 1348: } 1349: &register_handler("ls", \&ls_handler, 0, 1, 0); 1350: 1351: 1352: # Process a reinit request. Reinit requests that either 1353: # lonc or lond be reinitialized so that an updated 1354: # host.tab or domain.tab can be processed. 1355: # 1356: # Parameters: 1357: # $cmd - the actual keyword that invoked us. 1358: # $tail - the tail of the request that invoked us. 1359: # $client - File descriptor connected to the client 1360: # Returns: 1361: # 1 - Ok to continue processing. 1362: # 0 - Program should exit 1363: # Implicit output: 1364: # a reply is sent to the client. 1365: # 1366: sub reinit_process_handler { 1367: my ($cmd, $tail, $client) = @_; 1368: 1369: my $userinput = "$cmd:$tail"; 1370: 1371: my $cert = &GetCertificate($userinput); 1372: if(&ValidManager($cert)) { 1373: chomp($userinput); 1374: my $reply = &ReinitProcess($userinput); 1375: &Reply( $client, "$reply\n", $userinput); 1376: } else { 1377: &Failure( $client, "refused\n", $userinput); 1378: } 1379: return 1; 1380: } 1381: 1382: &register_handler("reinit", \&reinit_process_handler, 1, 0, 1); 1383: 1384: # Process the editing script for a table edit operation. 1385: # the editing operation must be encrypted and requested by 1386: # a manager host. 1387: # 1388: # Parameters: 1389: # $cmd - the actual keyword that invoked us. 1390: # $tail - the tail of the request that invoked us. 1391: # $client - File descriptor connected to the client 1392: # Returns: 1393: # 1 - Ok to continue processing. 1394: # 0 - Program should exit 1395: # Implicit output: 1396: # a reply is sent to the client. 1397: # 1398: sub edit_table_handler { 1399: my ($command, $tail, $client) = @_; 1400: 1401: my $userinput = "$command:$tail"; 1402: 1403: my $cert = &GetCertificate($userinput); 1404: if(&ValidManager($cert)) { 1405: my($filetype, $script) = split(/:/, $tail); 1406: if (($filetype eq "hosts") || 1407: ($filetype eq "domain")) { 1408: if($script ne "") { 1409: &Reply($client, # BUGBUG - EditFile 1410: &EditFile($userinput), # could fail. 1411: $userinput); 1412: } else { 1413: &Failure($client,"refused\n",$userinput); 1414: } 1415: } else { 1416: &Failure($client,"refused\n",$userinput); 1417: } 1418: } else { 1419: &Failure($client,"refused\n",$userinput); 1420: } 1421: return 1; 1422: } 1423: register_handler("edit", \&edit_table_handler, 1, 0, 1); 1424: 1425: 1426: # 1427: # Authenticate a user against the LonCAPA authentication 1428: # database. Note that there are several authentication 1429: # possibilities: 1430: # - unix - The user can be authenticated against the unix 1431: # password file. 1432: # - internal - The user can be authenticated against a purely 1433: # internal per user password file. 1434: # - kerberos - The user can be authenticated against either a kerb4 or kerb5 1435: # ticket granting authority. 1436: # - user - The person tailoring LonCAPA can supply a user authentication 1437: # mechanism that is per system. 1438: # 1439: # Parameters: 1440: # $cmd - The command that got us here. 1441: # $tail - Tail of the command (remaining parameters). 1442: # $client - File descriptor connected to client. 1443: # Returns 1444: # 0 - Requested to exit, caller should shut down. 1445: # 1 - Continue processing. 1446: # Implicit inputs: 1447: # The authentication systems describe above have their own forms of implicit 1448: # input into the authentication process that are described above. 1449: # 1450: sub authenticate_handler { 1451: my ($cmd, $tail, $client) = @_; 1452: 1453: 1454: # Regenerate the full input line 1455: 1456: my $userinput = $cmd.":".$tail; 1457: 1458: # udom - User's domain. 1459: # uname - Username. 1460: # upass - User's password. 1461: 1462: my ($udom,$uname,$upass)=split(/:/,$tail); 1463: &Debug(" Authenticate domain = $udom, user = $uname, password = $upass"); 1464: chomp($upass); 1465: $upass=&unescape($upass); 1466: 1467: my $pwdcorrect = &validate_user($udom, $uname, $upass); 1468: if($pwdcorrect) { 1469: &Reply( $client, "authorized\n", $userinput); 1470: # 1471: # Bad credentials: Failed to authorize 1472: # 1473: } else { 1474: &Failure( $client, "non_authorized\n", $userinput); 1475: } 1476: 1477: return 1; 1478: } 1479: 1480: register_handler("auth", \&authenticate_handler, 1, 1, 0); 1481: 1482: # 1483: # Change a user's password. Note that this function is complicated by 1484: # the fact that a user may be authenticated in more than one way: 1485: # At present, we are not able to change the password for all types of 1486: # authentication methods. Only for: 1487: # unix - unix password or shadow passoword style authentication. 1488: # local - Locally written authentication mechanism. 1489: # For now, kerb4 and kerb5 password changes are not supported and result 1490: # in an error. 1491: # FUTURE WORK: 1492: # Support kerberos passwd changes? 1493: # Parameters: 1494: # $cmd - The command that got us here. 1495: # $tail - Tail of the command (remaining parameters). 1496: # $client - File descriptor connected to client. 1497: # Returns 1498: # 0 - Requested to exit, caller should shut down. 1499: # 1 - Continue processing. 1500: # Implicit inputs: 1501: # The authentication systems describe above have their own forms of implicit 1502: # input into the authentication process that are described above. 1503: sub change_password_handler { 1504: my ($cmd, $tail, $client) = @_; 1505: 1506: my $userinput = $cmd.":".$tail; # Reconstruct client's string. 1507: 1508: # 1509: # udom - user's domain. 1510: # uname - Username. 1511: # upass - Current password. 1512: # npass - New password. 1513: 1514: my ($udom,$uname,$upass,$npass)=split(/:/,$tail); 1515: 1516: $upass=&unescape($upass); 1517: $npass=&unescape($npass); 1518: &Debug("Trying to change password for $uname"); 1519: 1520: # First require that the user can be authenticated with their 1521: # old password: 1522: 1523: my $validated = &validate_user($udom, $uname, $upass); 1524: if($validated) { 1525: my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd. 1526: 1527: my ($howpwd,$contentpwd)=split(/:/,$realpasswd); 1528: if ($howpwd eq 'internal') { 1529: &Debug("internal auth"); 1530: my $salt=time; 1531: $salt=substr($salt,6,2); 1532: my $ncpass=crypt($npass,$salt); 1533: if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) { 1534: &logthis("Result of password change for " 1535: ."$uname: pwchange_success"); 1536: &Reply($client, "ok\n", $userinput); 1537: } else { 1538: &logthis("Unable to open $uname passwd " 1539: ."to change password"); 1540: &Failure( $client, "non_authorized\n",$userinput); 1541: } 1542: } elsif ($howpwd eq 'unix') { 1543: # Unix means we have to access /etc/password 1544: &Debug("auth is unix"); 1545: my $execdir=$perlvar{'lonDaemons'}; 1546: &Debug("Opening lcpasswd pipeline"); 1547: my $pf = IO::File->new("|$execdir/lcpasswd > " 1548: ."$perlvar{'lonDaemons'}" 1549: ."/logs/lcpasswd.log"); 1550: print $pf "$uname\n$npass\n$npass\n"; 1551: close $pf; 1552: my $err = $?; 1553: my $result = ($err>0 ? 'pwchange_failure' : 'ok'); 1554: &logthis("Result of password change for $uname: ". 1555: &lcpasswdstrerror($?)); 1556: &Reply($client, "$result\n", $userinput); 1557: } else { 1558: # this just means that the current password mode is not 1559: # one we know how to change (e.g the kerberos auth modes or 1560: # locally written auth handler). 1561: # 1562: &Failure( $client, "auth_mode_error\n", $userinput); 1563: } 1564: 1565: } else { 1566: &Failure( $client, "non_authorized\n", $userinput); 1567: } 1568: 1569: return 1; 1570: } 1571: register_handler("passwd", \&change_password_handler, 1, 1, 0); 1572: 1573: 1574: # 1575: # Create a new user. User in this case means a lon-capa user. 1576: # The user must either already exist in some authentication realm 1577: # like kerberos or the /etc/passwd. If not, a user completely local to 1578: # this loncapa system is created. 1579: # 1580: # Parameters: 1581: # $cmd - The command that got us here. 1582: # $tail - Tail of the command (remaining parameters). 1583: # $client - File descriptor connected to client. 1584: # Returns 1585: # 0 - Requested to exit, caller should shut down. 1586: # 1 - Continue processing. 1587: # Implicit inputs: 1588: # The authentication systems describe above have their own forms of implicit 1589: # input into the authentication process that are described above. 1590: sub add_user_handler { 1591: 1592: my ($cmd, $tail, $client) = @_; 1593: 1594: 1595: my ($udom,$uname,$umode,$npass)=split(/:/,$tail); 1596: my $userinput = $cmd.":".$tail; # Reconstruct the full request line. 1597: 1598: &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname); 1599: 1600: 1601: if($udom eq $currentdomainid) { # Reject new users for other domains... 1602: 1603: my $oldumask=umask(0077); 1604: chomp($npass); 1605: $npass=&unescape($npass); 1606: my $passfilename = &password_path($udom, $uname); 1607: &Debug("Password file created will be:".$passfilename); 1608: if (-e $passfilename) { 1609: &Failure( $client, "already_exists\n", $userinput); 1610: } else { 1611: my @fpparts=split(/\//,$passfilename); 1612: my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; 1613: my $fperror=''; 1614: for (my $i=3;$i<= ($#fpparts-1);$i++) { 1615: $fpnow.='/'.$fpparts[$i]; 1616: unless (-e $fpnow) { 1617: &logthis("mkdir $fpnow"); 1618: unless (mkdir($fpnow,0777)) { 1619: $fperror="error: ".($!+0)." mkdir failed while attempting " 1620: ."makeuser"; 1621: } 1622: } 1623: } 1624: unless ($fperror) { 1625: my $result=&make_passwd_file($uname, $umode,$npass, $passfilename); 1626: &Reply($client, $result, $userinput); #BUGBUG - could be fail 1627: } else { 1628: &Failure($client, "$fperror\n", $userinput); 1629: } 1630: } 1631: umask($oldumask); 1632: } else { 1633: &Failure($client, "not_right_domain\n", 1634: $userinput); # Even if we are multihomed. 1635: 1636: } 1637: return 1; 1638: 1639: } 1640: &register_handler("makeuser", \&add_user_handler, 1, 1, 0); 1641: 1642: # 1643: # Change the authentication method of a user. Note that this may 1644: # also implicitly change the user's password if, for example, the user is 1645: # joining an existing authentication realm. Known authentication realms at 1646: # this time are: 1647: # internal - Purely internal password file (only loncapa knows this user) 1648: # local - Institutionally written authentication module. 1649: # unix - Unix user (/etc/passwd with or without /etc/shadow). 1650: # kerb4 - kerberos version 4 1651: # kerb5 - kerberos version 5 1652: # 1653: # Parameters: 1654: # $cmd - The command that got us here. 1655: # $tail - Tail of the command (remaining parameters). 1656: # $client - File descriptor connected to client. 1657: # Returns 1658: # 0 - Requested to exit, caller should shut down. 1659: # 1 - Continue processing. 1660: # Implicit inputs: 1661: # The authentication systems describe above have their own forms of implicit 1662: # input into the authentication process that are described above. 1663: # 1664: sub change_authentication_handler { 1665: 1666: my ($cmd, $tail, $client) = @_; 1667: 1668: my $userinput = "$cmd:$tail"; # Reconstruct user input. 1669: 1670: my ($udom,$uname,$umode,$npass)=split(/:/,$tail); 1671: &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode); 1672: if ($udom ne $currentdomainid) { 1673: &Failure( $client, "not_right_domain\n", $client); 1674: } else { 1675: 1676: chomp($npass); 1677: 1678: $npass=&unescape($npass); 1679: my $passfilename = &password_path($udom, $uname); 1680: if ($passfilename) { # Not allowed to create a new user!! 1681: my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); 1682: &Reply($client, $result, $userinput); 1683: } else { 1684: &Failure($client, "non_authorized", $userinput); # Fail the user now. 1685: } 1686: } 1687: return 1; 1688: } 1689: &register_handler("changeuserauth", \&change_authentication_handler, 1,1, 0); 1690: 1691: # 1692: # Determines if this is the home server for a user. The home server 1693: # for a user will have his/her lon-capa passwd file. Therefore all we need 1694: # to do is determine if this file exists. 1695: # 1696: # Parameters: 1697: # $cmd - The command that got us here. 1698: # $tail - Tail of the command (remaining parameters). 1699: # $client - File descriptor connected to client. 1700: # Returns 1701: # 0 - Requested to exit, caller should shut down. 1702: # 1 - Continue processing. 1703: # Implicit inputs: 1704: # The authentication systems describe above have their own forms of implicit 1705: # input into the authentication process that are described above. 1706: # 1707: sub is_home_handler { 1708: my ($cmd, $tail, $client) = @_; 1709: 1710: my $userinput = "$cmd:$tail"; 1711: 1712: my ($udom,$uname)=split(/:/,$tail); 1713: chomp($uname); 1714: my $passfile = &password_filename($udom, $uname); 1715: if($passfile) { 1716: &Reply( $client, "found\n", $userinput); 1717: } else { 1718: &Failure($client, "not_found\n", $userinput); 1719: } 1720: return 1; 1721: } 1722: &register_handler("home", \&is_home_handler, 0,1,0); 1723: 1724: # 1725: # Process an update request for a resource?? I think what's going on here is 1726: # that a resource has been modified that we hold a subscription to. 1727: # If the resource is not local, then we must update, or at least invalidate our 1728: # cached copy of the resource. 1729: # FUTURE WORK: 1730: # I need to look at this logic carefully. My druthers would be to follow 1731: # typical caching logic, and simple invalidate the cache, drop any subscription 1732: # an let the next fetch start the ball rolling again... however that may 1733: # actually be more difficult than it looks given the complex web of 1734: # proxy servers. 1735: # Parameters: 1736: # $cmd - The command that got us here. 1737: # $tail - Tail of the command (remaining parameters). 1738: # $client - File descriptor connected to client. 1739: # Returns 1740: # 0 - Requested to exit, caller should shut down. 1741: # 1 - Continue processing. 1742: # Implicit inputs: 1743: # The authentication systems describe above have their own forms of implicit 1744: # input into the authentication process that are described above. 1745: # 1746: sub update_resource_handler { 1747: 1748: my ($cmd, $tail, $client) = @_; 1749: 1750: my $userinput = "$cmd:$tail"; 1751: 1752: my $fname= $tail; # This allows interactive testing 1753: 1754: 1755: my $ownership=ishome($fname); 1756: if ($ownership eq 'not_owner') { 1757: if (-e $fname) { 1758: my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, 1759: $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname); 1760: my $now=time; 1761: my $since=$now-$atime; 1762: if ($since>$perlvar{'lonExpire'}) { 1763: my $reply=&reply("unsub:$fname","$clientname"); 1764: unlink("$fname"); 1765: } else { 1766: my $transname="$fname.in.transfer"; 1767: my $remoteurl=&reply("sub:$fname","$clientname"); 1768: my $response; 1769: alarm(120); 1770: { 1771: my $ua=new LWP::UserAgent; 1772: my $request=new HTTP::Request('GET',"$remoteurl"); 1773: $response=$ua->request($request,$transname); 1774: } 1775: alarm(0); 1776: if ($response->is_error()) { 1777: unlink($transname); 1778: my $message=$response->status_line; 1779: &logthis("LWP GET: $message for $fname ($remoteurl)"); 1780: } else { 1781: if ($remoteurl!~/\.meta$/) { 1782: alarm(120); 1783: { 1784: my $ua=new LWP::UserAgent; 1785: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); 1786: my $mresponse=$ua->request($mrequest,$fname.'.meta'); 1787: if ($mresponse->is_error()) { 1788: unlink($fname.'.meta'); 1789: } 1790: } 1791: alarm(0); 1792: } 1793: rename($transname,$fname); 1794: } 1795: } 1796: &Reply( $client, "ok\n", $userinput); 1797: } else { 1798: &Failure($client, "not_found\n", $userinput); 1799: } 1800: } else { 1801: &Failure($client, "rejected\n", $userinput); 1802: } 1803: return 1; 1804: } 1805: &register_handler("update", \&update_resource_handler, 0 ,1, 0); 1806: 1807: # 1808: # Fetch a user file from a remote server to the user's home directory 1809: # userfiles subdir. 1810: # Parameters: 1811: # $cmd - The command that got us here. 1812: # $tail - Tail of the command (remaining parameters). 1813: # $client - File descriptor connected to client. 1814: # Returns 1815: # 0 - Requested to exit, caller should shut down. 1816: # 1 - Continue processing. 1817: # 1818: sub fetch_user_file_handler { 1819: 1820: my ($cmd, $tail, $client) = @_; 1821: 1822: my $userinput = "$cmd:$tail"; 1823: my $fname = $tail; 1824: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); 1825: my $udir=&propath($udom,$uname).'/userfiles'; 1826: unless (-e $udir) { 1827: mkdir($udir,0770); 1828: } 1829: Debug("fetch user file for $fname"); 1830: if (-e $udir) { 1831: $ufile=~s/^[\.\~]+//; 1832: 1833: # IF necessary, create the path right down to the file. 1834: # Note that any regular files in the way of this path are 1835: # wiped out to deal with some earlier folly of mine. 1836: 1837: my $path = $udir; 1838: if ($ufile =~m|(.+)/([^/]+)$|) { 1839: my @parts=split('/',$1); 1840: foreach my $part (@parts) { 1841: $path .= '/'.$part; 1842: if( -f $path) { 1843: unlink($path); 1844: } 1845: if ((-e $path)!=1) { 1846: mkdir($path,0770); 1847: } 1848: } 1849: } 1850: 1851: 1852: my $destname=$udir.'/'.$ufile; 1853: my $transname=$udir.'/'.$ufile.'.in.transit'; 1854: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; 1855: my $response; 1856: Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname"); 1857: alarm(120); 1858: { 1859: my $ua=new LWP::UserAgent; 1860: my $request=new HTTP::Request('GET',"$remoteurl"); 1861: $response=$ua->request($request,$transname); 1862: } 1863: alarm(0); 1864: if ($response->is_error()) { 1865: unlink($transname); 1866: my $message=$response->status_line; 1867: &logthis("LWP GET: $message for $fname ($remoteurl)"); 1868: &Failure($client, "failed\n", $userinput); 1869: } else { 1870: Debug("Renaming $transname to $destname"); 1871: if (!rename($transname,$destname)) { 1872: &logthis("Unable to move $transname to $destname"); 1873: unlink($transname); 1874: &Failure($client, "failed\n", $userinput); 1875: } else { 1876: &Reply($client, "ok\n", $userinput); 1877: } 1878: } 1879: } else { 1880: &Failure($client, "not_home\n", $userinput); 1881: } 1882: return 1; 1883: } 1884: &register_handler("fetchuserfile", \&fetch_user_file_handler, 0, 1, 0); 1885: 1886: # 1887: # Remove a file from a user's home directory userfiles subdirectory. 1888: # Parameters: 1889: # cmd - the Lond request keyword that got us here. 1890: # tail - the part of the command past the keyword. 1891: # client- File descriptor connected with the client. 1892: # 1893: # Returns: 1894: # 1 - Continue processing. 1895: 1896: sub remove_user_file_handler { 1897: my ($cmd, $tail, $client) = @_; 1898: 1899: my ($fname) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent. 1900: 1901: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); 1902: if ($ufile =~m|/\.\./|) { 1903: # any files paths with /../ in them refuse 1904: # to deal with 1905: &Failure($client, "refused\n", "$cmd:$tail"); 1906: } else { 1907: my $udir = &propath($udom,$uname); 1908: if (-e $udir) { 1909: my $file=$udir.'/userfiles/'.$ufile; 1910: if (-e $file) { 1911: unlink($file); 1912: if (-e $file) { 1913: &Failure($client, "failed\n", "$cmd:$tail"); 1914: } else { 1915: &Reply($client, "ok\n", "$cmd:$tail"); 1916: } 1917: } else { 1918: &Failure($client, "not_found\n", "$cmd:$tail"); 1919: } 1920: } else { 1921: &Failure($client, "not_home\n", "$cmd:$tail"); 1922: } 1923: } 1924: return 1; 1925: } 1926: &register_handler("removeuserfile", \&remove_user_file_handler, 0,1,0); 1927: 1928: # 1929: # make a directory in a user's home directory userfiles subdirectory. 1930: # Parameters: 1931: # cmd - the Lond request keyword that got us here. 1932: # tail - the part of the command past the keyword. 1933: # client- File descriptor connected with the client. 1934: # 1935: # Returns: 1936: # 1 - Continue processing. 1937: 1938: sub mkdir_user_file_handler { 1939: my ($cmd, $tail, $client) = @_; 1940: 1941: my ($dir) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent. 1942: $dir=&unescape($dir); 1943: my ($udom,$uname,$ufile) = ($dir =~ m|^([^/]+)/([^/]+)/(.+)$|); 1944: if ($ufile =~m|/\.\./|) { 1945: # any files paths with /../ in them refuse 1946: # to deal with 1947: &Failure($client, "refused\n", "$cmd:$tail"); 1948: } else { 1949: my $udir = &propath($udom,$uname); 1950: if (-e $udir) { 1951: my $newdir=$udir.'/userfiles/'.$ufile; 1952: if (!-e $newdir) { 1953: mkdir($newdir); 1954: if (!-e $newdir) { 1955: &Failure($client, "failed\n", "$cmd:$tail"); 1956: } else { 1957: &Reply($client, "ok\n", "$cmd:$tail"); 1958: } 1959: } else { 1960: &Failure($client, "not_found\n", "$cmd:$tail"); 1961: } 1962: } else { 1963: &Failure($client, "not_home\n", "$cmd:$tail"); 1964: } 1965: } 1966: return 1; 1967: } 1968: &register_handler("mkdiruserfile", \&mkdir_user_file_handler, 0,1,0); 1969: 1970: # 1971: # rename a file in a user's home directory userfiles subdirectory. 1972: # Parameters: 1973: # cmd - the Lond request keyword that got us here. 1974: # tail - the part of the command past the keyword. 1975: # client- File descriptor connected with the client. 1976: # 1977: # Returns: 1978: # 1 - Continue processing. 1979: 1980: sub rename_user_file_handler { 1981: my ($cmd, $tail, $client) = @_; 1982: 1983: my ($udom,$uname,$old,$new) = split(/:/, $tail); 1984: $old=&unescape($old); 1985: $new=&unescape($new); 1986: if ($new =~m|/\.\./| || $old =~m|/\.\./|) { 1987: # any files paths with /../ in them refuse to deal with 1988: &Failure($client, "refused\n", "$cmd:$tail"); 1989: } else { 1990: my $udir = &propath($udom,$uname); 1991: if (-e $udir) { 1992: my $oldfile=$udir.'/userfiles/'.$old; 1993: my $newfile=$udir.'/userfiles/'.$new; 1994: if (-e $newfile) { 1995: &Failure($client, "exists\n", "$cmd:$tail"); 1996: } elsif (! -e $oldfile) { 1997: &Failure($client, "not_found\n", "$cmd:$tail"); 1998: } else { 1999: if (!rename($oldfile,$newfile)) { 2000: &Failure($client, "failed\n", "$cmd:$tail"); 2001: } else { 2002: &Reply($client, "ok\n", "$cmd:$tail"); 2003: } 2004: } 2005: } else { 2006: &Failure($client, "not_home\n", "$cmd:$tail"); 2007: } 2008: } 2009: return 1; 2010: } 2011: &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0); 2012: 2013: 2014: # 2015: # Authenticate access to a user file by checking the user's 2016: # session token(?) 2017: # 2018: # Parameters: 2019: # cmd - The request keyword that dispatched to tus. 2020: # tail - The tail of the request (colon separated parameters). 2021: # client - Filehandle open on the client. 2022: # Return: 2023: # 1. 2024: 2025: sub token_auth_user_file_handler { 2026: my ($cmd, $tail, $client) = @_; 2027: 2028: my ($fname, $session) = split(/:/, $tail); 2029: 2030: chomp($session); 2031: my $reply='non_auth'; 2032: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. 2033: $session.'.id')) { 2034: while (my $line=<ENVIN>) { 2035: if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; } 2036: } 2037: close(ENVIN); 2038: &Reply($client, $reply); 2039: } else { 2040: &Failure($client, "invalid_token\n", "$cmd:$tail"); 2041: } 2042: return 1; 2043: 2044: } 2045: 2046: &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0); 2047: 2048: 2049: # 2050: # Unsubscribe from a resource. 2051: # 2052: # Parameters: 2053: # $cmd - The command that got us here. 2054: # $tail - Tail of the command (remaining parameters). 2055: # $client - File descriptor connected to client. 2056: # Returns 2057: # 0 - Requested to exit, caller should shut down. 2058: # 1 - Continue processing. 2059: # 2060: sub unsubscribe_handler { 2061: my ($cmd, $tail, $client) = @_; 2062: 2063: my $userinput= "$cmd:$tail"; 2064: 2065: my ($fname) = split(/:/,$tail); # Split in case there's extrs. 2066: 2067: &Debug("Unsubscribing $fname"); 2068: if (-e $fname) { 2069: &Debug("Exists"); 2070: &Reply($client, &unsub($fname,$clientip), $userinput); 2071: } else { 2072: &Failure($client, "not_found\n", $userinput); 2073: } 2074: return 1; 2075: } 2076: &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0); 2077: # Subscribe to a resource 2078: # 2079: # Parameters: 2080: # $cmd - The command that got us here. 2081: # $tail - Tail of the command (remaining parameters). 2082: # $client - File descriptor connected to client. 2083: # Returns 2084: # 0 - Requested to exit, caller should shut down. 2085: # 1 - Continue processing. 2086: # 2087: sub subscribe_handler { 2088: my ($cmd, $tail, $client)= @_; 2089: 2090: my $userinput = "$cmd:$tail"; 2091: 2092: &Reply( $client, &subscribe($userinput,$clientip), $userinput); 2093: 2094: return 1; 2095: } 2096: &register_handler("sub", \&subscribe_handler, 0, 1, 0); 2097: 2098: # 2099: # Determine the version of a resource (?) Or is it return 2100: # the top version of the resource? Not yet clear from the 2101: # code in currentversion. 2102: # 2103: # Parameters: 2104: # $cmd - The command that got us here. 2105: # $tail - Tail of the command (remaining parameters). 2106: # $client - File descriptor connected to client. 2107: # Returns 2108: # 0 - Requested to exit, caller should shut down. 2109: # 1 - Continue processing. 2110: # 2111: sub current_version_handler { 2112: my ($cmd, $tail, $client) = @_; 2113: 2114: my $userinput= "$cmd:$tail"; 2115: 2116: my $fname = $tail; 2117: &Reply( $client, &currentversion($fname)."\n", $userinput); 2118: return 1; 2119: 2120: } 2121: &register_handler("currentversion", \&current_version_handler, 0, 1, 0); 2122: 2123: # Make an entry in a user's activity log. 2124: # 2125: # Parameters: 2126: # $cmd - The command that got us here. 2127: # $tail - Tail of the command (remaining parameters). 2128: # $client - File descriptor connected to client. 2129: # Returns 2130: # 0 - Requested to exit, caller should shut down. 2131: # 1 - Continue processing. 2132: # 2133: sub activity_log_handler { 2134: my ($cmd, $tail, $client) = @_; 2135: 2136: 2137: my $userinput= "$cmd:$tail"; 2138: 2139: my ($udom,$uname,$what)=split(/:/,$tail); 2140: chomp($what); 2141: my $proname=&propath($udom,$uname); 2142: my $now=time; 2143: my $hfh; 2144: if ($hfh=IO::File->new(">>$proname/activity.log")) { 2145: print $hfh "$now:$clientname:$what\n"; 2146: &Reply( $client, "ok\n", $userinput); 2147: } else { 2148: &Failure($client, "error: ".($!+0)." IO::File->new Failed " 2149: ."while attempting log\n", 2150: $userinput); 2151: } 2152: 2153: return 1; 2154: } 2155: register_handler("log", \&activity_log_handler, 0, 1, 0); 2156: 2157: # 2158: # Put a namespace entry in a user profile hash. 2159: # My druthers would be for this to be an encrypted interaction too. 2160: # anything that might be an inadvertent covert channel about either 2161: # user authentication or user personal information.... 2162: # 2163: # Parameters: 2164: # $cmd - The command that got us here. 2165: # $tail - Tail of the command (remaining parameters). 2166: # $client - File descriptor connected to client. 2167: # Returns 2168: # 0 - Requested to exit, caller should shut down. 2169: # 1 - Continue processing. 2170: # 2171: sub put_user_profile_entry { 2172: my ($cmd, $tail, $client) = @_; 2173: 2174: my $userinput = "$cmd:$tail"; 2175: 2176: my ($udom,$uname,$namespace,$what) =split(/:/,$tail); 2177: if ($namespace ne 'roles') { 2178: chomp($what); 2179: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2180: &GDBM_WRCREAT(),"P",$what); 2181: if($hashref) { 2182: my @pairs=split(/\&/,$what); 2183: foreach my $pair (@pairs) { 2184: my ($key,$value)=split(/=/,$pair); 2185: $hashref->{$key}=$value; 2186: } 2187: if (untie(%$hashref)) { 2188: &Reply( $client, "ok\n", $userinput); 2189: } else { 2190: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". 2191: "while attempting put\n", 2192: $userinput); 2193: } 2194: } else { 2195: &Failure( $client, "error: ".($!)." tie(GDBM) Failed ". 2196: "while attempting put\n", $userinput); 2197: } 2198: } else { 2199: &Failure( $client, "refused\n", $userinput); 2200: } 2201: 2202: return 1; 2203: } 2204: &register_handler("put", \&put_user_profile_entry, 0, 1, 0); 2205: 2206: # 2207: # Increment a profile entry in the user history file. 2208: # The history contains keyword value pairs. In this case, 2209: # The value itself is a pair of numbers. The first, the current value 2210: # the second an increment that this function applies to the current 2211: # value. 2212: # 2213: # Parameters: 2214: # $cmd - The command that got us here. 2215: # $tail - Tail of the command (remaining parameters). 2216: # $client - File descriptor connected to client. 2217: # Returns 2218: # 0 - Requested to exit, caller should shut down. 2219: # 1 - Continue processing. 2220: # 2221: sub increment_user_value_handler { 2222: my ($cmd, $tail, $client) = @_; 2223: 2224: my $userinput = "$cmd:$tail"; 2225: 2226: my ($udom,$uname,$namespace,$what) =split(/:/,$tail); 2227: if ($namespace ne 'roles') { 2228: chomp($what); 2229: my $hashref = &tie_user_hash($udom, $uname, 2230: $namespace, &GDBM_WRCREAT(), 2231: "P",$what); 2232: if ($hashref) { 2233: my @pairs=split(/\&/,$what); 2234: foreach my $pair (@pairs) { 2235: my ($key,$value)=split(/=/,$pair); 2236: # We could check that we have a number... 2237: if (! defined($value) || $value eq '') { 2238: $value = 1; 2239: } 2240: $hashref->{$key}+=$value; 2241: } 2242: if (untie(%$hashref)) { 2243: &Reply( $client, "ok\n", $userinput); 2244: } else { 2245: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". 2246: "while attempting inc\n", $userinput); 2247: } 2248: } else { 2249: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2250: "while attempting inc\n", $userinput); 2251: } 2252: } else { 2253: &Failure($client, "refused\n", $userinput); 2254: } 2255: 2256: return 1; 2257: } 2258: &register_handler("inc", \&increment_user_value_handler, 0, 1, 0); 2259: 2260: 2261: # 2262: # Put a new role for a user. Roles are LonCAPA's packaging of permissions. 2263: # Each 'role' a user has implies a set of permissions. Adding a new role 2264: # for a person grants the permissions packaged with that role 2265: # to that user when the role is selected. 2266: # 2267: # Parameters: 2268: # $cmd - The command string (rolesput). 2269: # $tail - The remainder of the request line. For rolesput this 2270: # consists of a colon separated list that contains: 2271: # The domain and user that is granting the role (logged). 2272: # The domain and user that is getting the role. 2273: # The roles being granted as a set of & separated pairs. 2274: # each pair a key value pair. 2275: # $client - File descriptor connected to the client. 2276: # Returns: 2277: # 0 - If the daemon should exit 2278: # 1 - To continue processing. 2279: # 2280: # 2281: sub roles_put_handler { 2282: my ($cmd, $tail, $client) = @_; 2283: 2284: my $userinput = "$cmd:$tail"; 2285: 2286: my ( $exedom, $exeuser, $udom, $uname, $what) = split(/:/,$tail); 2287: 2288: 2289: my $namespace='roles'; 2290: chomp($what); 2291: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2292: &GDBM_WRCREAT(), "P", 2293: "$exedom:$exeuser:$what"); 2294: # 2295: # Log the attempt to set a role. The {}'s here ensure that the file 2296: # handle is open for the minimal amount of time. Since the flush 2297: # is done on close this improves the chances the log will be an un- 2298: # corrupted ordered thing. 2299: if ($hashref) { 2300: my @pairs=split(/\&/,$what); 2301: foreach my $pair (@pairs) { 2302: my ($key,$value)=split(/=/,$pair); 2303: &manage_permissions($key, $udom, $uname, 2304: &get_auth_type( $udom, $uname)); 2305: $hashref->{$key}=$value; 2306: } 2307: if (untie($hashref)) { 2308: &Reply($client, "ok\n", $userinput); 2309: } else { 2310: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 2311: "while attempting rolesput\n", $userinput); 2312: } 2313: } else { 2314: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2315: "while attempting rolesput\n", $userinput); 2316: } 2317: return 1; 2318: } 2319: &register_handler("rolesput", \&roles_put_handler, 1,1,0); # Encoded client only. 2320: 2321: # 2322: # Deletes (removes) a role for a user. This is equivalent to removing 2323: # a permissions package associated with the role from the user's profile. 2324: # 2325: # Parameters: 2326: # $cmd - The command (rolesdel) 2327: # $tail - The remainder of the request line. This consists 2328: # of: 2329: # The domain and user requesting the change (logged) 2330: # The domain and user being changed. 2331: # The roles being revoked. These are shipped to us 2332: # as a bunch of & separated role name keywords. 2333: # $client - The file handle open on the client. 2334: # Returns: 2335: # 1 - Continue processing 2336: # 0 - Exit. 2337: # 2338: sub roles_delete_handler { 2339: my ($cmd, $tail, $client) = @_; 2340: 2341: my $userinput = "$cmd:$tail"; 2342: 2343: my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail); 2344: &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom. 2345: "what = ".$what); 2346: my $namespace='roles'; 2347: chomp($what); 2348: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2349: &GDBM_WRCREAT(), "D", 2350: "$exedom:$exeuser:$what"); 2351: 2352: if ($hashref) { 2353: my @rolekeys=split(/\&/,$what); 2354: 2355: foreach my $key (@rolekeys) { 2356: delete $hashref->{$key}; 2357: } 2358: if (untie(%$hashref)) { 2359: &Reply($client, "ok\n", $userinput); 2360: } else { 2361: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 2362: "while attempting rolesdel\n", $userinput); 2363: } 2364: } else { 2365: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2366: "while attempting rolesdel\n", $userinput); 2367: } 2368: 2369: return 1; 2370: } 2371: &register_handler("rolesdel", \&roles_delete_handler, 1,1, 0); # Encoded client only 2372: 2373: # Unencrypted get from a user's profile database. See 2374: # GetProfileEntryEncrypted for a version that does end-to-end encryption. 2375: # This function retrieves a keyed item from a specific named database in the 2376: # user's directory. 2377: # 2378: # Parameters: 2379: # $cmd - Command request keyword (get). 2380: # $tail - Tail of the command. This is a colon separated list 2381: # consisting of the domain and username that uniquely 2382: # identifies the profile, 2383: # The 'namespace' which selects the gdbm file to 2384: # do the lookup in, 2385: # & separated list of keys to lookup. Note that 2386: # the values are returned as an & separated list too. 2387: # $client - File descriptor open on the client. 2388: # Returns: 2389: # 1 - Continue processing. 2390: # 0 - Exit. 2391: # 2392: sub get_profile_entry { 2393: my ($cmd, $tail, $client) = @_; 2394: 2395: my $userinput= "$cmd:$tail"; 2396: 2397: my ($udom,$uname,$namespace,$what) = split(/:/,$tail); 2398: chomp($what); 2399: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2400: &GDBM_READER()); 2401: if ($hashref) { 2402: my @queries=split(/\&/,$what); 2403: my $qresult=''; 2404: 2405: for (my $i=0;$i<=$#queries;$i++) { 2406: $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. 2407: } 2408: $qresult=~s/\&$//; # Remove trailing & from last lookup. 2409: if (untie(%$hashref)) { 2410: &Reply($client, "$qresult\n", $userinput); 2411: } else { 2412: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2413: "while attempting get\n", $userinput); 2414: } 2415: } else { 2416: if ($!+0 == 2) { # +0 coerces errno -> number 2 is ENOENT 2417: &Failure($client, "error:No such file or ". 2418: "GDBM reported bad block error\n", $userinput); 2419: } else { # Some other undifferentiated err. 2420: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2421: "while attempting get\n", $userinput); 2422: } 2423: } 2424: return 1; 2425: } 2426: &register_handler("get", \&get_profile_entry, 0,1,0); 2427: 2428: # 2429: # Process the encrypted get request. Note that the request is sent 2430: # in clear, but the reply is encrypted. This is a small covert channel: 2431: # information about the sensitive keys is given to the snooper. Just not 2432: # information about the values of the sensitive key. Hmm if I wanted to 2433: # know these I'd snoop for the egets. Get the profile item names from them 2434: # and then issue a get for them since there's no enforcement of the 2435: # requirement of an encrypted get for particular profile items. If I 2436: # were re-doing this, I'd force the request to be encrypted as well as the 2437: # reply. I'd also just enforce encrypted transactions for all gets since 2438: # that would prevent any covert channel snooping. 2439: # 2440: # Parameters: 2441: # $cmd - Command keyword of request (eget). 2442: # $tail - Tail of the command. See GetProfileEntry # for more information about this. 2443: # $client - File open on the client. 2444: # Returns: 2445: # 1 - Continue processing 2446: # 0 - server should exit. 2447: sub get_profile_entry_encrypted { 2448: my ($cmd, $tail, $client) = @_; 2449: 2450: my $userinput = "$cmd:$tail"; 2451: 2452: my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput); 2453: chomp($what); 2454: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2455: &GDBM_READER()); 2456: if ($hashref) { 2457: my @queries=split(/\&/,$what); 2458: my $qresult=''; 2459: for (my $i=0;$i<=$#queries;$i++) { 2460: $qresult.="$hashref->{$queries[$i]}&"; 2461: } 2462: if (untie(%$hashref)) { 2463: $qresult=~s/\&$//; 2464: if ($cipher) { 2465: my $cmdlength=length($qresult); 2466: $qresult.=" "; 2467: my $encqresult=''; 2468: for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { 2469: $encqresult.= unpack("H16", 2470: $cipher->encrypt(substr($qresult, 2471: $encidx, 2472: 8))); 2473: } 2474: &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput); 2475: } else { 2476: &Failure( $client, "error:no_key\n", $userinput); 2477: } 2478: } else { 2479: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2480: "while attempting eget\n", $userinput); 2481: } 2482: } else { 2483: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2484: "while attempting eget\n", $userinput); 2485: } 2486: 2487: return 1; 2488: } 2489: &register_handler("eget", \&GetProfileEntryEncrypted, 0, 1, 0); 2490: # 2491: # Deletes a key in a user profile database. 2492: # 2493: # Parameters: 2494: # $cmd - Command keyword (del). 2495: # $tail - Command tail. IN this case a colon 2496: # separated list containing: 2497: # The domain and user that identifies uniquely 2498: # the identity of the user. 2499: # The profile namespace (name of the profile 2500: # database file). 2501: # & separated list of keywords to delete. 2502: # $client - File open on client socket. 2503: # Returns: 2504: # 1 - Continue processing 2505: # 0 - Exit server. 2506: # 2507: # 2508: 2509: sub delete_profile_entry { 2510: my ($cmd, $tail, $client) = @_; 2511: 2512: my $userinput = "cmd:$tail"; 2513: 2514: my ($udom,$uname,$namespace,$what) = split(/:/,$tail); 2515: chomp($what); 2516: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2517: &GDBM_WRCREAT(), 2518: "D",$what); 2519: if ($hashref) { 2520: my @keys=split(/\&/,$what); 2521: foreach my $key (@keys) { 2522: delete($hashref->{$key}); 2523: } 2524: if (untie(%$hashref)) { 2525: &Reply($client, "ok\n", $userinput); 2526: } else { 2527: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2528: "while attempting del\n", $userinput); 2529: } 2530: } else { 2531: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2532: "while attempting del\n", $userinput); 2533: } 2534: return 1; 2535: } 2536: &register_handler("del", \&delete_profile_entry, 0, 1, 0); 2537: # 2538: # List the set of keys that are defined in a profile database file. 2539: # A successful reply from this will contain an & separated list of 2540: # the keys. 2541: # Parameters: 2542: # $cmd - Command request (keys). 2543: # $tail - Remainder of the request, a colon separated 2544: # list containing domain/user that identifies the 2545: # user being queried, and the database namespace 2546: # (database filename essentially). 2547: # $client - File open on the client. 2548: # Returns: 2549: # 1 - Continue processing. 2550: # 0 - Exit the server. 2551: # 2552: sub get_profile_keys { 2553: my ($cmd, $tail, $client) = @_; 2554: 2555: my $userinput = "$cmd:$tail"; 2556: 2557: my ($udom,$uname,$namespace)=split(/:/,$tail); 2558: my $qresult=''; 2559: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2560: &GDBM_READER()); 2561: if ($hashref) { 2562: foreach my $key (keys %$hashref) { 2563: $qresult.="$key&"; 2564: } 2565: if (untie(%$hashref)) { 2566: $qresult=~s/\&$//; 2567: &Reply($client, "$qresult\n", $userinput); 2568: } else { 2569: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2570: "while attempting keys\n", $userinput); 2571: } 2572: } else { 2573: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2574: "while attempting keys\n", $userinput); 2575: } 2576: 2577: return 1; 2578: } 2579: &register_handler("keys", \&get_profile_keys, 0, 1, 0); 2580: 2581: # 2582: # Dump the contents of a user profile database. 2583: # Note that this constitutes a very large covert channel too since 2584: # the dump will return sensitive information that is not encrypted. 2585: # The naive security assumption is that the session negotiation ensures 2586: # our client is trusted and I don't believe that's assured at present. 2587: # Sure want badly to go to ssl or tls. Of course if my peer isn't really 2588: # a LonCAPA node they could have negotiated an encryption key too so >sigh<. 2589: # 2590: # Parameters: 2591: # $cmd - The command request keyword (currentdump). 2592: # $tail - Remainder of the request, consisting of a colon 2593: # separated list that has the domain/username and 2594: # the namespace to dump (database file). 2595: # $client - file open on the remote client. 2596: # Returns: 2597: # 1 - Continue processing. 2598: # 0 - Exit the server. 2599: # 2600: sub dump_profile_database { 2601: my ($cmd, $tail, $client) = @_; 2602: 2603: my $userinput = "$cmd:$tail"; 2604: 2605: my ($udom,$uname,$namespace) = split(/:/,$tail); 2606: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2607: &GDBM_READER()); 2608: if ($hashref) { 2609: # Structure of %data: 2610: # $data{$symb}->{$parameter}=$value; 2611: # $data{$symb}->{'v.'.$parameter}=$version; 2612: # since $parameter will be unescaped, we do not 2613: # have to worry about silly parameter names... 2614: 2615: my $qresult=''; 2616: my %data = (); # A hash of anonymous hashes.. 2617: while (my ($key,$value) = each(%$hashref)) { 2618: my ($v,$symb,$param) = split(/:/,$key); 2619: next if ($v eq 'version' || $symb eq 'keys'); 2620: next if (exists($data{$symb}) && 2621: exists($data{$symb}->{$param}) && 2622: $data{$symb}->{'v.'.$param} > $v); 2623: $data{$symb}->{$param}=$value; 2624: $data{$symb}->{'v.'.$param}=$v; 2625: } 2626: if (untie(%$hashref)) { 2627: while (my ($symb,$param_hash) = each(%data)) { 2628: while(my ($param,$value) = each (%$param_hash)){ 2629: next if ($param =~ /^v\./); # Ignore versions... 2630: # 2631: # Just dump the symb=value pairs separated by & 2632: # 2633: $qresult.=$symb.':'.$param.'='.$value.'&'; 2634: } 2635: } 2636: chop($qresult); 2637: &Reply($client , "$qresult\n", $userinput); 2638: } else { 2639: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 2640: "while attempting currentdump\n", $userinput); 2641: } 2642: } else { 2643: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2644: "while attempting currentdump\n", $userinput); 2645: } 2646: 2647: return 1; 2648: } 2649: &register_handler("currentdump", \&dump_profile_database, 0, 1, 0); 2650: 2651: # 2652: # Dump a profile database with an optional regular expression 2653: # to match against the keys. In this dump, no effort is made 2654: # to separate symb from version information. Presumably the 2655: # databases that are dumped by this command are of a different 2656: # structure. Need to look at this and improve the documentation of 2657: # both this and the currentdump handler. 2658: # Parameters: 2659: # $cmd - The command keyword. 2660: # $tail - All of the characters after the $cmd: 2661: # These are expected to be a colon 2662: # separated list containing: 2663: # domain/user - identifying the user. 2664: # namespace - identifying the database. 2665: # regexp - optional regular expression 2666: # that is matched against 2667: # database keywords to do 2668: # selective dumps. 2669: # $client - Channel open on the client. 2670: # Returns: 2671: # 1 - Continue processing. 2672: # Side effects: 2673: # response is written to $client. 2674: # 2675: sub dump_with_regexp { 2676: my ($cmd, $tail, $client) = @_; 2677: 2678: 2679: my $userinput = "$cmd:$tail"; 2680: 2681: my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); 2682: if (defined($regexp)) { 2683: $regexp=&unescape($regexp); 2684: } else { 2685: $regexp='.'; 2686: } 2687: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2688: &GDBM_READER()); 2689: if ($hashref) { 2690: my $qresult=''; 2691: while (my ($key,$value) = each(%$hashref)) { 2692: if ($regexp eq '.') { 2693: $qresult.=$key.'='.$value.'&'; 2694: } else { 2695: my $unescapeKey = &unescape($key); 2696: if (eval('$unescapeKey=~/$regexp/')) { 2697: $qresult.="$key=$value&"; 2698: } 2699: } 2700: } 2701: if (untie(%$hashref)) { 2702: chop($qresult); 2703: &Reply($client, "$qresult\n", $userinput); 2704: } else { 2705: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 2706: "while attempting dump\n", $userinput); 2707: } 2708: } else { 2709: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2710: "while attempting dump\n", $userinput); 2711: } 2712: 2713: return 1; 2714: } 2715: 2716: &register_handler("dump", \&dump_with_regexp, 0, 1, 0); 2717: 2718: # Store a set of key=value pairs associated with a versioned name. 2719: # 2720: # Parameters: 2721: # $cmd - Request command keyword. 2722: # $tail - Tail of the request. This is a colon 2723: # separated list containing: 2724: # domain/user - User and authentication domain. 2725: # namespace - Name of the database being modified 2726: # rid - Resource keyword to modify. 2727: # what - new value associated with rid. 2728: # 2729: # $client - Socket open on the client. 2730: # 2731: # 2732: # Returns: 2733: # 1 (keep on processing). 2734: # Side-Effects: 2735: # Writes to the client 2736: sub store_handler { 2737: my ($cmd, $tail, $client) = @_; 2738: 2739: my $userinput = "$cmd:$tail"; 2740: 2741: my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail); 2742: if ($namespace ne 'roles') { 2743: 2744: chomp($what); 2745: my @pairs=split(/\&/,$what); 2746: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2747: &GDBM_WRCREAT(), "P", 2748: "$rid:$what"); 2749: if ($hashref) { 2750: my $now = time; 2751: my @previouskeys=split(/&/,$hashref->{"keys:$rid"}); 2752: my $key; 2753: $hashref->{"version:$rid"}++; 2754: my $version=$hashref->{"version:$rid"}; 2755: my $allkeys=''; 2756: foreach my $pair (@pairs) { 2757: my ($key,$value)=split(/=/,$pair); 2758: $allkeys.=$key.':'; 2759: $hashref->{"$version:$rid:$key"}=$value; 2760: } 2761: $hashref->{"$version:$rid:timestamp"}=$now; 2762: $allkeys.='timestamp'; 2763: $hashref->{"$version:keys:$rid"}=$allkeys; 2764: if (untie($hashref)) { 2765: &Reply($client, "ok\n", $userinput); 2766: } else { 2767: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2768: "while attempting store\n", $userinput); 2769: } 2770: } else { 2771: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2772: "while attempting store\n", $userinput); 2773: } 2774: } else { 2775: &Failure($client, "refused\n", $userinput); 2776: } 2777: 2778: return 1; 2779: } 2780: &register_handler("store", \&store_handler, 0, 1, 0); 2781: # 2782: # Dump out all versions of a resource that has key=value pairs associated 2783: # with it for each version. These resources are built up via the store 2784: # command. 2785: # 2786: # Parameters: 2787: # $cmd - Command keyword. 2788: # $tail - Remainder of the request which consists of: 2789: # domain/user - User and auth. domain. 2790: # namespace - name of resource database. 2791: # rid - Resource id. 2792: # $client - socket open on the client. 2793: # 2794: # Returns: 2795: # 1 indicating the caller should not yet exit. 2796: # Side-effects: 2797: # Writes a reply to the client. 2798: # The reply is a string of the following shape: 2799: # version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2... 2800: # Where the 1 above represents version 1. 2801: # this continues for all pairs of keys in all versions. 2802: # 2803: # 2804: # 2805: # 2806: sub restore_handler { 2807: my ($cmd, $tail, $client) = @_; 2808: 2809: my $userinput = "$cmd:$tail"; # Only used for logging purposes. 2810: 2811: my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput); 2812: $namespace=~s/\//\_/g; 2813: $namespace=~s/\W//g; 2814: chomp($rid); 2815: my $proname=&propath($udom,$uname); 2816: my $qresult=''; 2817: my %hash; 2818: if (tie(%hash,'GDBM_File',"$proname/$namespace.db", 2819: &GDBM_READER(),0640)) { 2820: my $version=$hash{"version:$rid"}; 2821: $qresult.="version=$version&"; 2822: my $scope; 2823: for ($scope=1;$scope<=$version;$scope++) { 2824: my $vkeys=$hash{"$scope:keys:$rid"}; 2825: my @keys=split(/:/,$vkeys); 2826: my $key; 2827: $qresult.="$scope:keys=$vkeys&"; 2828: foreach $key (@keys) { 2829: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; 2830: } 2831: } 2832: if (untie(%hash)) { 2833: $qresult=~s/\&$//; 2834: &Reply( $client, "$qresult\n", $userinput); 2835: } else { 2836: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2837: "while attempting restore\n", $userinput); 2838: } 2839: } else { 2840: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2841: "while attempting restore\n", $userinput); 2842: } 2843: 2844: return 1; 2845: 2846: 2847: } 2848: &register_handler("restore", \&restore_handler, 0,1,0); 2849: 2850: # 2851: # Add a chat message to to a discussion board. 2852: # 2853: # Parameters: 2854: # $cmd - Request keyword. 2855: # $tail - Tail of the command. A colon separated list 2856: # containing: 2857: # cdom - Domain on which the chat board lives 2858: # cnum - Identifier of the discussion group. 2859: # post - Body of the posting. 2860: # $client - Socket open on the client. 2861: # Returns: 2862: # 1 - Indicating caller should keep on processing. 2863: # 2864: # Side-effects: 2865: # writes a reply to the client. 2866: # 2867: # 2868: sub send_chat_handler { 2869: my ($cmd, $tail, $client) = @_; 2870: 2871: 2872: my $userinput = "$cmd:$tail"; 2873: 2874: my ($cdom,$cnum,$newpost)=split(/\:/,$tail); 2875: &chat_add($cdom,$cnum,$newpost); 2876: &Reply($client, "ok\n", $userinput); 2877: 2878: return 1; 2879: } 2880: &register_handler("chatsend", \&send_chat_handler, 0, 1, 0); 2881: # 2882: # Retrieve the set of chat messagss from a discussion board. 2883: # 2884: # Parameters: 2885: # $cmd - Command keyword that initiated the request. 2886: # $tail - Remainder of the request after the command 2887: # keyword. In this case a colon separated list of 2888: # chat domain - Which discussion board. 2889: # chat id - Discussion thread(?) 2890: # domain/user - Authentication domain and username 2891: # of the requesting person. 2892: # $client - Socket open on the client program. 2893: # Returns: 2894: # 1 - continue processing 2895: # Side effects: 2896: # Response is written to the client. 2897: # 2898: sub retrieve_chat_handler { 2899: my ($cmd, $tail, $client) = @_; 2900: 2901: 2902: my $userinput = "$cmd:$tail"; 2903: 2904: my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail); 2905: my $reply=''; 2906: foreach (&get_chat($cdom,$cnum,$udom,$uname)) { 2907: $reply.=&escape($_).':'; 2908: } 2909: $reply=~s/\:$//; 2910: &Reply($client, $reply."\n", $userinput); 2911: 2912: 2913: return 1; 2914: } 2915: &register_handler("chatretr", \&retrieve_chat_handler, 0, 1, 0); 2916: 2917: # 2918: # Initiate a query of an sql database. SQL query repsonses get put in 2919: # a file for later retrieval. This prevents sql query results from 2920: # bottlenecking the system. Note that with loncnew, perhaps this is 2921: # less of an issue since multiple outstanding requests can be concurrently 2922: # serviced. 2923: # 2924: # Parameters: 2925: # $cmd - COmmand keyword that initiated the request. 2926: # $tail - Remainder of the command after the keyword. 2927: # For this function, this consists of a query and 2928: # 3 arguments that are self-documentingly labelled 2929: # in the original arg1, arg2, arg3. 2930: # $client - Socket open on the client. 2931: # Return: 2932: # 1 - Indicating processing should continue. 2933: # Side-effects: 2934: # a reply is written to $client. 2935: # 2936: sub send_query_handler { 2937: my ($cmd, $tail, $client) = @_; 2938: 2939: 2940: my $userinput = "$cmd:$tail"; 2941: 2942: my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail); 2943: $query=~s/\n*$//g; 2944: &Reply($client, "". &sql_reply("$clientname\&$query". 2945: "\&$arg1"."\&$arg2"."\&$arg3")."\n", 2946: $userinput); 2947: 2948: return 1; 2949: } 2950: &register_handler("querysend", \&send_query_handler, 0, 1, 0); 2951: 2952: # 2953: # Add a reply to an sql query. SQL queries are done asyncrhonously. 2954: # The query is submitted via a "querysend" transaction. 2955: # There it is passed on to the lonsql daemon, queued and issued to 2956: # mysql. 2957: # This transaction is invoked when the sql transaction is complete 2958: # it stores the query results in flie and indicates query completion. 2959: # presumably local software then fetches this response... I'm guessing 2960: # the sequence is: lonc does a querysend, we ask lonsql to do it. 2961: # lonsql on completion of the query interacts with the lond of our 2962: # client to do a query reply storing two files: 2963: # - id - The results of the query. 2964: # - id.end - Indicating the transaction completed. 2965: # NOTE: id is a unique id assigned to the query and querysend time. 2966: # Parameters: 2967: # $cmd - Command keyword that initiated this request. 2968: # $tail - Remainder of the tail. In this case that's a colon 2969: # separated list containing the query Id and the 2970: # results of the query. 2971: # $client - Socket open on the client. 2972: # Return: 2973: # 1 - Indicating that we should continue processing. 2974: # Side effects: 2975: # ok written to the client. 2976: # 2977: sub reply_query_handler { 2978: my ($cmd, $tail, $client) = @_; 2979: 2980: 2981: my $userinput = "$cmd:$tail"; 2982: 2983: my ($cmd,$id,$reply)=split(/:/,$userinput); 2984: my $store; 2985: my $execdir=$perlvar{'lonDaemons'}; 2986: if ($store=IO::File->new(">$execdir/tmp/$id")) { 2987: $reply=~s/\&/\n/g; 2988: print $store $reply; 2989: close $store; 2990: my $store2=IO::File->new(">$execdir/tmp/$id.end"); 2991: print $store2 "done\n"; 2992: close $store2; 2993: &Reply($client, "ok\n", $userinput); 2994: } else { 2995: &Failure($client, "error: ".($!+0) 2996: ." IO::File->new Failed ". 2997: "while attempting queryreply\n", $userinput); 2998: } 2999: 3000: 3001: return 1; 3002: } 3003: &register_handler("queryreply", \&reply_query_handler, 0, 1, 0); 3004: 3005: # 3006: # Process the courseidput request. Not quite sure what this means 3007: # at the system level sense. It appears a gdbm file in the 3008: # /home/httpd/lonUsers/$domain/nohist_courseids is tied and 3009: # a set of entries made in that database. 3010: # 3011: # Parameters: 3012: # $cmd - The command keyword that initiated this request. 3013: # $tail - Tail of the command. In this case consists of a colon 3014: # separated list contaning the domain to apply this to and 3015: # an ampersand separated list of keyword=value pairs. 3016: # $client - Socket open on the client. 3017: # Returns: 3018: # 1 - indicating that processing should continue 3019: # 3020: # Side effects: 3021: # reply is written to the client. 3022: # 3023: sub put_course_id_handler { 3024: my ($cmd, $tail, $client) = @_; 3025: 3026: 3027: my $userinput = "$cmd:$tail"; 3028: 3029: my ($udom, $what) = split(/:/, $tail); 3030: chomp($what); 3031: my $now=time; 3032: my @pairs=split(/\&/,$what); 3033: 3034: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); 3035: if ($hashref) { 3036: foreach my $pair (@pairs) { 3037: my ($key,$value)=split(/=/,$pair); 3038: $hashref->{$key}=$value.':'.$now; 3039: } 3040: if (untie(%$hashref)) { 3041: &Reply($client, "ok\n", $userinput); 3042: } else { 3043: &Failure( $client, "error: ".($!+0) 3044: ." untie(GDBM) Failed ". 3045: "while attempting courseidput\n", $userinput); 3046: } 3047: } else { 3048: &Failure( $client, "error: ".($!+0) 3049: ." tie(GDBM) Failed ". 3050: "while attempting courseidput\n", $userinput); 3051: } 3052: 3053: return 1; 3054: } 3055: &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0); 3056: 3057: # Retrieves the value of a course id resource keyword pattern 3058: # defined since a starting date. Both the starting date and the 3059: # keyword pattern are optional. If the starting date is not supplied it 3060: # is treated as the beginning of time. If the pattern is not found, 3061: # it is treatred as "." matching everything. 3062: # 3063: # Parameters: 3064: # $cmd - Command keyword that resulted in us being dispatched. 3065: # $tail - The remainder of the command that, in this case, consists 3066: # of a colon separated list of: 3067: # domain - The domain in which the course database is 3068: # defined. 3069: # since - Optional parameter describing the minimum 3070: # time of definition(?) of the resources that 3071: # will match the dump. 3072: # description - regular expression that is used to filter 3073: # the dump. Only keywords matching this regexp 3074: # will be used. 3075: # $client - The socket open on the client. 3076: # Returns: 3077: # 1 - Continue processing. 3078: # Side Effects: 3079: # a reply is written to $client. 3080: sub dump_course_id_handler { 3081: my ($cmd, $tail, $client) = @_; 3082: 3083: my $userinput = "$cmd:$tail"; 3084: 3085: my ($udom,$since,$description) =split(/:/,$tail); 3086: if (defined($description)) { 3087: $description=&unescape($description); 3088: } else { 3089: $description='.'; 3090: } 3091: unless (defined($since)) { $since=0; } 3092: my $qresult=''; 3093: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); 3094: if ($hashref) { 3095: while (my ($key,$value) = each(%$hashref)) { 3096: my ($descr,$lasttime,$inst_code); 3097: if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { 3098: ($descr,$inst_code,$lasttime)=($1,$2,$3); 3099: } else { 3100: ($descr,$lasttime) = split(/\:/,$value); 3101: } 3102: if ($lasttime<$since) { next; } 3103: if ($description eq '.') { 3104: $qresult.=$key.'='.$descr.':'.$inst_code.'&'; 3105: } else { 3106: my $unescapeVal = &unescape($descr); 3107: if (eval('$unescapeVal=~/\Q$description\E/i')) { 3108: $qresult.=$key.'='.$descr.':'.$inst_code.'&'; 3109: } 3110: } 3111: } 3112: if (untie(%$hashref)) { 3113: chop($qresult); 3114: &Reply($client, "$qresult\n", $userinput); 3115: } else { 3116: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 3117: "while attempting courseiddump\n", $userinput); 3118: } 3119: } else { 3120: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 3121: "while attempting courseiddump\n", $userinput); 3122: } 3123: 3124: 3125: return 1; 3126: } 3127: &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0); 3128: 3129: # 3130: # Puts an id to a domains id database. 3131: # 3132: # Parameters: 3133: # $cmd - The command that triggered us. 3134: # $tail - Remainder of the request other than the command. This is a 3135: # colon separated list containing: 3136: # $domain - The domain for which we are writing the id. 3137: # $pairs - The id info to write... this is and & separated list 3138: # of keyword=value. 3139: # $client - Socket open on the client. 3140: # Returns: 3141: # 1 - Continue processing. 3142: # Side effects: 3143: # reply is written to $client. 3144: # 3145: sub put_id_handler { 3146: my ($cmd,$tail,$client) = @_; 3147: 3148: 3149: my $userinput = "$cmd:$tail"; 3150: 3151: my ($udom,$what)=split(/:/,$tail); 3152: chomp($what); 3153: my @pairs=split(/\&/,$what); 3154: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(), 3155: "P", $what); 3156: if ($hashref) { 3157: foreach my $pair (@pairs) { 3158: my ($key,$value)=split(/=/,$pair); 3159: $hashref->{$key}=$value; 3160: } 3161: if (untie(%$hashref)) { 3162: &Reply($client, "ok\n", $userinput); 3163: } else { 3164: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 3165: "while attempting idput\n", $userinput); 3166: } 3167: } else { 3168: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 3169: "while attempting idput\n", $userinput); 3170: } 3171: 3172: return 1; 3173: } 3174: 3175: &register_handler("idput", \&put_id_handler, 0, 1, 0); 3176: # 3177: # Retrieves a set of id values from the id database. 3178: # Returns an & separated list of results, one for each requested id to the 3179: # client. 3180: # 3181: # Parameters: 3182: # $cmd - Command keyword that caused us to be dispatched. 3183: # $tail - Tail of the command. Consists of a colon separated: 3184: # domain - the domain whose id table we dump 3185: # ids Consists of an & separated list of 3186: # id keywords whose values will be fetched. 3187: # nonexisting keywords will have an empty value. 3188: # $client - Socket open on the client. 3189: # 3190: # Returns: 3191: # 1 - indicating processing should continue. 3192: # Side effects: 3193: # An & separated list of results is written to $client. 3194: # 3195: sub get_id_handler { 3196: my ($cmd, $tail, $client) = @_; 3197: 3198: 3199: my $userinput = "$client:$tail"; 3200: 3201: my ($udom,$what)=split(/:/,$tail); 3202: chomp($what); 3203: my @queries=split(/\&/,$what); 3204: my $qresult=''; 3205: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_READER()); 3206: if ($hashref) { 3207: for (my $i=0;$i<=$#queries;$i++) { 3208: $qresult.="$hashref->{$queries[$i]}&"; 3209: } 3210: if (untie(%$hashref)) { 3211: $qresult=~s/\&$//; 3212: &Reply($client, "$qresult\n", $userinput); 3213: } else { 3214: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 3215: "while attempting idget\n",$userinput); 3216: } 3217: } else { 3218: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 3219: "while attempting idget\n",$userinput); 3220: } 3221: 3222: return 1; 3223: } 3224: 3225: register_handler("idget", \&get_id_handler, 0, 1, 0); 3226: 3227: # 3228: # Process the tmpput command I'm not sure what this does.. Seems to 3229: # create a file in the lonDaemons/tmp directory of the form $id.tmp 3230: # where Id is the client's ip concatenated with a sequence number. 3231: # The file will contain some value that is passed in. Is this e.g. 3232: # a login token? 3233: # 3234: # Parameters: 3235: # $cmd - The command that got us dispatched. 3236: # $tail - The remainder of the request following $cmd: 3237: # In this case this will be the contents of the file. 3238: # $client - Socket connected to the client. 3239: # Returns: 3240: # 1 indicating processing can continue. 3241: # Side effects: 3242: # A file is created in the local filesystem. 3243: # A reply is sent to the client. 3244: sub tmp_put_handler { 3245: my ($cmd, $what, $client) = @_; 3246: 3247: my $userinput = "$cmd:$what"; # Reconstruct for logging. 3248: 3249: 3250: my $store; 3251: $tmpsnum++; 3252: my $id=$$.'_'.$clientip.'_'.$tmpsnum; 3253: $id=~s/\W/\_/g; 3254: $what=~s/\n//g; 3255: my $execdir=$perlvar{'lonDaemons'}; 3256: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { 3257: print $store $what; 3258: close $store; 3259: &Reply($client, "$id\n", $userinput); 3260: } else { 3261: &Failure( $client, "error: ".($!+0)."IO::File->new Failed ". 3262: "while attempting tmpput\n", $userinput); 3263: } 3264: return 1; 3265: 3266: } 3267: &register_handler("tmpput", \&tmp_put_handler, 0, 1, 0); 3268: # Processes the tmpget command. This command returns the contents 3269: # of a temporary resource file(?) created via tmpput. 3270: # 3271: # Paramters: 3272: # $cmd - Command that got us dispatched. 3273: # $id - Tail of the command, contain the id of the resource 3274: # we want to fetch. 3275: # $client - socket open on the client. 3276: # Return: 3277: # 1 - Inidcating processing can continue. 3278: # Side effects: 3279: # A reply is sent to the client. 3280: 3281: # 3282: sub tmp_get_handler { 3283: my ($cmd, $id, $client) = @_; 3284: 3285: my $userinput = "$cmd:$id"; 3286: 3287: 3288: $id=~s/\W/\_/g; 3289: my $store; 3290: my $execdir=$perlvar{'lonDaemons'}; 3291: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { 3292: my $reply=<$store>; 3293: &Reply( $client, "$reply\n", $userinput); 3294: close $store; 3295: } else { 3296: &Failure( $client, "error: ".($!+0)."IO::File->new Failed ". 3297: "while attempting tmpget\n", $userinput); 3298: } 3299: 3300: return 1; 3301: } 3302: &register_handler("tmpget", \&tmp_get_handler, 0, 1, 0); 3303: # 3304: # Process the tmpdel command. This command deletes a temp resource 3305: # created by the tmpput command. 3306: # 3307: # Parameters: 3308: # $cmd - Command that got us here. 3309: # $id - Id of the temporary resource created. 3310: # $client - socket open on the client process. 3311: # 3312: # Returns: 3313: # 1 - Indicating processing should continue. 3314: # Side Effects: 3315: # A file is deleted 3316: # A reply is sent to the client. 3317: sub tmp_del_handler { 3318: my ($cmd, $id, $client) = @_; 3319: 3320: my $userinput= "$cmd:$id"; 3321: 3322: chomp($id); 3323: $id=~s/\W/\_/g; 3324: my $execdir=$perlvar{'lonDaemons'}; 3325: if (unlink("$execdir/tmp/$id.tmp")) { 3326: &Reply($client, "ok\n", $userinput); 3327: } else { 3328: &Failure( $client, "error: ".($!+0)."Unlink tmp Failed ". 3329: "while attempting tmpdel\n", $userinput); 3330: } 3331: 3332: return 1; 3333: 3334: } 3335: &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0); 3336: # 3337: # 3338: # 3339: # 3340: #--------------------------------------------------------------- 3341: # 3342: # Getting, decoding and dispatching requests: 3343: # 3344: 3345: # 3346: # Get a Request: 3347: # Gets a Request message from the client. The transaction 3348: # is defined as a 'line' of text. We remove the new line 3349: # from the text line. 3350: # 3351: sub get_request { 3352: my $input = <$client>; 3353: chomp($input); 3354: 3355: &Debug("get_request: Request = $input\n"); 3356: 3357: &status('Processing '.$clientname.':'.$input); 3358: 3359: return $input; 3360: } 3361: #--------------------------------------------------------------- 3362: # 3363: # Process a request. This sub should shrink as each action 3364: # gets farmed out into a separat sub that is registered 3365: # with the dispatch hash. 3366: # 3367: # Parameters: 3368: # user_input - The request received from the client (lonc). 3369: # Returns: 3370: # true to keep processing, false if caller should exit. 3371: # 3372: sub process_request { 3373: my ($userinput) = @_; # Easier for now to break style than to 3374: # fix all the userinput -> user_input. 3375: my $wasenc = 0; # True if request was encrypted. 3376: # ------------------------------------------------------------ See if encrypted 3377: if ($userinput =~ /^enc/) { 3378: $userinput = decipher($userinput); 3379: $wasenc=1; 3380: if(!$userinput) { # Cipher not defined. 3381: &Failure($client, "error: Encrypted data without negotated key"); 3382: return 0; 3383: } 3384: } 3385: Debug("process_request: $userinput\n"); 3386: 3387: # 3388: # The 'correct way' to add a command to lond is now to 3389: # write a sub to execute it and Add it to the command dispatch 3390: # hash via a call to register_handler.. The comments to that 3391: # sub should give you enough to go on to show how to do this 3392: # along with the examples that are building up as this code 3393: # is getting refactored. Until all branches of the 3394: # if/elseif monster below have been factored out into 3395: # separate procesor subs, if the dispatch hash is missing 3396: # the command keyword, we will fall through to the remainder 3397: # of the if/else chain below in order to keep this thing in 3398: # working order throughout the transmogrification. 3399: 3400: my ($command, $tail) = split(/:/, $userinput, 2); 3401: chomp($command); 3402: chomp($tail); 3403: $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet. 3404: $command =~ s/(\r)//; # And this too for parameterless commands. 3405: if(!$tail) { 3406: $tail =""; # defined but blank. 3407: } 3408: 3409: &Debug("Command received: $command, encoded = $wasenc"); 3410: 3411: if(defined $Dispatcher{$command}) { 3412: 3413: my $dispatch_info = $Dispatcher{$command}; 3414: my $handler = $$dispatch_info[0]; 3415: my $need_encode = $$dispatch_info[1]; 3416: my $client_types = $$dispatch_info[2]; 3417: Debug("Matched dispatch hash: mustencode: $need_encode " 3418: ."ClientType $client_types"); 3419: 3420: # Validate the request: 3421: 3422: my $ok = 1; 3423: my $requesterprivs = 0; 3424: if(&isClient()) { 3425: $requesterprivs |= $CLIENT_OK; 3426: } 3427: if(&isManager()) { 3428: $requesterprivs |= $MANAGER_OK; 3429: } 3430: if($need_encode && (!$wasenc)) { 3431: Debug("Must encode but wasn't: $need_encode $wasenc"); 3432: $ok = 0; 3433: } 3434: if(($client_types & $requesterprivs) == 0) { 3435: Debug("Client not privileged to do this operation"); 3436: $ok = 0; 3437: } 3438: 3439: if($ok) { 3440: Debug("Dispatching to handler $command $tail"); 3441: my $keep_going = &$handler($command, $tail, $client); 3442: return $keep_going; 3443: } else { 3444: Debug("Refusing to dispatch because client did not match requirements"); 3445: Failure($client, "refused\n", $userinput); 3446: return 1; 3447: } 3448: 3449: } 3450: 3451: #------------------- Commands not yet in spearate handlers. -------------- 3452: 3453: 3454: 3455: # ----------------------------------------------------------------- setannounce 3456: if ($userinput =~ /^setannounce/) { 3457: if (isClient) { 3458: my ($cmd,$announcement)=split(/:/,$userinput); 3459: chomp($announcement); 3460: $announcement=&unescape($announcement); 3461: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. 3462: '/announcement.txt')) { 3463: print $store $announcement; 3464: close $store; 3465: print $client "ok\n"; 3466: } else { 3467: print $client "error: ".($!+0)."\n"; 3468: } 3469: } else { 3470: Reply($client, "refused\n", $userinput); 3471: 3472: } 3473: # ------------------------------------------------------------------ Hanging up 3474: } elsif (($userinput =~ /^exit/) || 3475: ($userinput =~ /^init/)) { # no restrictions. 3476: &logthis( 3477: "Client $clientip ($clientname) hanging up: $userinput"); 3478: print $client "bye\n"; 3479: $client->shutdown(2); # shutdown the socket forcibly. 3480: $client->close(); 3481: return 0; 3482: 3483: # ---------------------------------- set current host/domain 3484: } elsif ($userinput =~ /^sethost/) { 3485: if (isClient) { 3486: print $client &sethost($userinput)."\n"; 3487: } else { 3488: print $client "refused\n"; 3489: } 3490: #---------------------------------- request file (?) version. 3491: } elsif ($userinput =~/^version/) { 3492: if (isClient) { 3493: print $client &version($userinput)."\n"; 3494: } else { 3495: print $client "refused\n"; 3496: } 3497: #------------------------------- is auto-enrollment enabled? 3498: } elsif ($userinput =~/^autorun/) { 3499: if (isClient) { 3500: my ($cmd,$cdom) = split(/:/,$userinput); 3501: my $outcome = &localenroll::run($cdom); 3502: print $client "$outcome\n"; 3503: } else { 3504: print $client "0\n"; 3505: } 3506: #------------------------------- get official sections (for auto-enrollment). 3507: } elsif ($userinput =~/^autogetsections/) { 3508: if (isClient) { 3509: my ($cmd,$coursecode,$cdom)=split(/:/,$userinput); 3510: my @secs = &localenroll::get_sections($coursecode,$cdom); 3511: my $seclist = &escape(join(':',@secs)); 3512: print $client "$seclist\n"; 3513: } else { 3514: print $client "refused\n"; 3515: } 3516: #----------------------- validate owner of new course section (for auto-enrollment). 3517: } elsif ($userinput =~/^autonewcourse/) { 3518: if (isClient) { 3519: my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput); 3520: my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); 3521: print $client "$outcome\n"; 3522: } else { 3523: print $client "refused\n"; 3524: } 3525: #-------------- validate course section in schedule of classes (for auto-enrollment). 3526: } elsif ($userinput =~/^autovalidatecourse/) { 3527: if (isClient) { 3528: my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput); 3529: my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom); 3530: print $client "$outcome\n"; 3531: } else { 3532: print $client "refused\n"; 3533: } 3534: #--------------------------- create password for new user (for auto-enrollment). 3535: } elsif ($userinput =~/^autocreatepassword/) { 3536: if (isClient) { 3537: my ($cmd,$authparam,$cdom)=split(/:/,$userinput); 3538: my ($create_passwd,$authchk); 3539: ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom); 3540: print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n"; 3541: } else { 3542: print $client "refused\n"; 3543: } 3544: #--------------------------- read and remove temporary files (for auto-enrollment). 3545: } elsif ($userinput =~/^autoretrieve/) { 3546: if (isClient) { 3547: my ($cmd,$filename) = split(/:/,$userinput); 3548: my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename; 3549: if ( (-e $source) && ($filename ne '') ) { 3550: my $reply = ''; 3551: if (open(my $fh,$source)) { 3552: while (<$fh>) { 3553: chomp($_); 3554: $_ =~ s/^\s+//g; 3555: $_ =~ s/\s+$//g; 3556: $reply .= $_; 3557: } 3558: close($fh); 3559: print $client &escape($reply)."\n"; 3560: # unlink($source); 3561: } else { 3562: print $client "error\n"; 3563: } 3564: } else { 3565: print $client "error\n"; 3566: } 3567: } else { 3568: print $client "refused\n"; 3569: } 3570: #--------------------- read and retrieve institutional code format (for support form). 3571: } elsif ($userinput =~/^autoinstcodeformat/) { 3572: if (isClient) { 3573: my $reply; 3574: my($cmd,$cdom,$course) = split(/:/,$userinput); 3575: my @pairs = split/\&/,$course; 3576: my %instcodes = (); 3577: my %codes = (); 3578: my @codetitles = (); 3579: my %cat_titles = (); 3580: my %cat_order = (); 3581: foreach (@pairs) { 3582: my ($key,$value) = split/=/,$_; 3583: $instcodes{&unescape($key)} = &unescape($value); 3584: } 3585: my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order); 3586: if ($formatreply eq 'ok') { 3587: my $codes_str = &hash2str(%codes); 3588: my $codetitles_str = &array2str(@codetitles); 3589: my $cat_titles_str = &hash2str(%cat_titles); 3590: my $cat_order_str = &hash2str(%cat_order); 3591: print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n"; 3592: } 3593: } else { 3594: print $client "refused\n"; 3595: } 3596: # ------------------------------------------------------------- unknown command 3597: 3598: } else { 3599: # unknown command 3600: print $client "unknown_cmd\n"; 3601: } 3602: # -------------------------------------------------------------------- complete 3603: Debug("process_request - returning 1"); 3604: return 1; 3605: } 3606: # 3607: # Decipher encoded traffic 3608: # Parameters: 3609: # input - Encoded data. 3610: # Returns: 3611: # Decoded data or undef if encryption key was not yet negotiated. 3612: # Implicit input: 3613: # cipher - This global holds the negotiated encryption key. 3614: # 3615: sub decipher { 3616: my ($input) = @_; 3617: my $output = ''; 3618: 3619: 3620: if($cipher) { 3621: my($enc, $enclength, $encinput) = split(/:/, $input); 3622: for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) { 3623: $output .= 3624: $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16))); 3625: } 3626: return substr($output, 0, $enclength); 3627: } else { 3628: return undef; 3629: } 3630: } 3631: 3632: # 3633: # Register a command processor. This function is invoked to register a sub 3634: # to process a request. Once registered, the ProcessRequest sub can automatically 3635: # dispatch requests to an appropriate sub, and do the top level validity checking 3636: # as well: 3637: # - Is the keyword recognized. 3638: # - Is the proper client type attempting the request. 3639: # - Is the request encrypted if it has to be. 3640: # Parameters: 3641: # $request_name - Name of the request being registered. 3642: # This is the command request that will match 3643: # against the hash keywords to lookup the information 3644: # associated with the dispatch information. 3645: # $procedure - Reference to a sub to call to process the request. 3646: # All subs get called as follows: 3647: # Procedure($cmd, $tail, $replyfd, $key) 3648: # $cmd - the actual keyword that invoked us. 3649: # $tail - the tail of the request that invoked us. 3650: # $replyfd- File descriptor connected to the client 3651: # $must_encode - True if the request must be encoded to be good. 3652: # $client_ok - True if it's ok for a client to request this. 3653: # $manager_ok - True if it's ok for a manager to request this. 3654: # Side effects: 3655: # - On success, the Dispatcher hash has an entry added for the key $RequestName 3656: # - On failure, the program will die as it's a bad internal bug to try to 3657: # register a duplicate command handler. 3658: # 3659: sub register_handler { 3660: my ($request_name,$procedure,$must_encode, $client_ok,$manager_ok) = @_; 3661: 3662: # Don't allow duplication# 3663: 3664: if (defined $Dispatcher{$request_name}) { 3665: die "Attempting to define a duplicate request handler for $request_name\n"; 3666: } 3667: # Build the client type mask: 3668: 3669: my $client_type_mask = 0; 3670: if($client_ok) { 3671: $client_type_mask |= $CLIENT_OK; 3672: } 3673: if($manager_ok) { 3674: $client_type_mask |= $MANAGER_OK; 3675: } 3676: 3677: # Enter the hash: 3678: 3679: my @entry = ($procedure, $must_encode, $client_type_mask); 3680: 3681: $Dispatcher{$request_name} = \@entry; 3682: 3683: } 3684: 3685: 3686: #------------------------------------------------------------------ 3687: 3688: 3689: 3690: 3691: # 3692: # Convert an error return code from lcpasswd to a string value. 3693: # 3694: sub lcpasswdstrerror { 3695: my $ErrorCode = shift; 3696: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { 3697: return "lcpasswd Unrecognized error return value ".$ErrorCode; 3698: } else { 3699: return $passwderrors[$ErrorCode]; 3700: } 3701: } 3702: 3703: # 3704: # Convert an error return code from lcuseradd to a string value: 3705: # 3706: sub lcuseraddstrerror { 3707: my $ErrorCode = shift; 3708: if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) { 3709: return "lcuseradd - Unrecognized error code: ".$ErrorCode; 3710: } else { 3711: return $adderrors[$ErrorCode]; 3712: } 3713: } 3714: 3715: # grabs exception and records it to log before exiting 3716: sub catchexception { 3717: my ($error)=@_; 3718: $SIG{'QUIT'}='DEFAULT'; 3719: $SIG{__DIE__}='DEFAULT'; 3720: &status("Catching exception"); 3721: &logthis("CRITICAL: " 3722: ."ABNORMAL EXIT. Child $$ for server $thisserver died through " 3723: ."a crash with this error msg->[$error]"); 3724: &logthis('Famous last words: '.$status.' - '.$lastlog); 3725: if ($client) { print $client "error: $error\n"; } 3726: $server->close(); 3727: die($error); 3728: } 3729: sub timeout { 3730: &status("Handling Timeout"); 3731: &logthis("CRITICAL: TIME OUT ".$$.""); 3732: &catchexception('Timeout'); 3733: } 3734: # -------------------------------- Set signal handlers to record abnormal exits 3735: 3736: 3737: $SIG{'QUIT'}=\&catchexception; 3738: $SIG{__DIE__}=\&catchexception; 3739: 3740: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf 3741: &status("Read loncapa.conf and loncapa_apache.conf"); 3742: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); 3743: %perlvar=%{$perlvarref}; 3744: undef $perlvarref; 3745: 3746: # ----------------------------- Make sure this process is running from user=www 3747: my $wwwid=getpwnam('www'); 3748: if ($wwwid!=$<) { 3749: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 3750: my $subj="LON: $currenthostid User ID mismatch"; 3751: system("echo 'User ID mismatch. lond must be run as user www.' |\ 3752: mailto $emailto -s '$subj' > /dev/null"); 3753: exit 1; 3754: } 3755: 3756: # --------------------------------------------- Check if other instance running 3757: 3758: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; 3759: 3760: if (-e $pidfile) { 3761: my $lfh=IO::File->new("$pidfile"); 3762: my $pide=<$lfh>; 3763: chomp($pide); 3764: if (kill 0 => $pide) { die "already running"; } 3765: } 3766: 3767: # ------------------------------------------------------------- Read hosts file 3768: 3769: 3770: 3771: # establish SERVER socket, bind and listen. 3772: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'}, 3773: Type => SOCK_STREAM, 3774: Proto => 'tcp', 3775: Reuse => 1, 3776: Listen => 10 ) 3777: or die "making socket: $@\n"; 3778: 3779: # --------------------------------------------------------- Do global variables 3780: 3781: # global variables 3782: 3783: my %children = (); # keys are current child process IDs 3784: 3785: sub REAPER { # takes care of dead children 3786: $SIG{CHLD} = \&REAPER; 3787: &status("Handling child death"); 3788: my $pid; 3789: do { 3790: $pid = waitpid(-1,&WNOHANG()); 3791: if (defined($children{$pid})) { 3792: &logthis("Child $pid died"); 3793: delete($children{$pid}); 3794: } elsif ($pid > 0) { 3795: &logthis("Unknown Child $pid died"); 3796: } 3797: } while ( $pid > 0 ); 3798: foreach my $child (keys(%children)) { 3799: $pid = waitpid($child,&WNOHANG()); 3800: if ($pid > 0) { 3801: &logthis("Child $child - $pid looks like we missed it's death"); 3802: delete($children{$pid}); 3803: } 3804: } 3805: &status("Finished Handling child death"); 3806: } 3807: 3808: sub HUNTSMAN { # signal handler for SIGINT 3809: &status("Killing children (INT)"); 3810: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 3811: kill 'INT' => keys %children; 3812: &logthis("Free socket: ".shutdown($server,2)); # free up socket 3813: my $execdir=$perlvar{'lonDaemons'}; 3814: unlink("$execdir/logs/lond.pid"); 3815: &logthis("CRITICAL: Shutting down"); 3816: &status("Done killing children"); 3817: exit; # clean up with dignity 3818: } 3819: 3820: sub HUPSMAN { # signal handler for SIGHUP 3821: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 3822: &status("Killing children for restart (HUP)"); 3823: kill 'INT' => keys %children; 3824: &logthis("Free socket: ".shutdown($server,2)); # free up socket 3825: &logthis("CRITICAL: Restarting"); 3826: my $execdir=$perlvar{'lonDaemons'}; 3827: unlink("$execdir/logs/lond.pid"); 3828: &status("Restarting self (HUP)"); 3829: exec("$execdir/lond"); # here we go again 3830: } 3831: 3832: # 3833: # Kill off hashes that describe the host table prior to re-reading it. 3834: # Hashes affected are: 3835: # %hostid, %hostdom %hostip %hostdns. 3836: # 3837: sub KillHostHashes { 3838: foreach my $key (keys %hostid) { 3839: delete $hostid{$key}; 3840: } 3841: foreach my $key (keys %hostdom) { 3842: delete $hostdom{$key}; 3843: } 3844: foreach my $key (keys %hostip) { 3845: delete $hostip{$key}; 3846: } 3847: foreach my $key (keys %hostdns) { 3848: delete $hostdns{$key}; 3849: } 3850: } 3851: # 3852: # Read in the host table from file and distribute it into the various hashes: 3853: # 3854: # - %hostid - Indexed by IP, the loncapa hostname. 3855: # - %hostdom - Indexed by loncapa hostname, the domain. 3856: # - %hostip - Indexed by hostid, the Ip address of the host. 3857: sub ReadHostTable { 3858: 3859: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; 3860: my $myloncapaname = $perlvar{'lonHostID'}; 3861: Debug("My loncapa name is : $myloncapaname"); 3862: while (my $configline=<CONFIG>) { 3863: if (!($configline =~ /^\s*\#/)) { 3864: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); 3865: chomp($ip); $ip=~s/\D+$//; 3866: $hostid{$ip}=$id; # LonCAPA name of host by IP. 3867: $hostdom{$id}=$domain; # LonCAPA domain name of host. 3868: $hostip{$id}=$ip; # IP address of host. 3869: $hostdns{$name} = $id; # LonCAPA name of host by DNS. 3870: 3871: if ($id eq $perlvar{'lonHostID'}) { 3872: Debug("Found me in the host table: $name"); 3873: $thisserver=$name; 3874: } 3875: } 3876: } 3877: close(CONFIG); 3878: } 3879: # 3880: # Reload the Apache daemon's state. 3881: # This is done by invoking /home/httpd/perl/apachereload 3882: # a setuid perl script that can be root for us to do this job. 3883: # 3884: sub ReloadApache { 3885: my $execdir = $perlvar{'lonDaemons'}; 3886: my $script = $execdir."/apachereload"; 3887: system($script); 3888: } 3889: 3890: # 3891: # Called in response to a USR2 signal. 3892: # - Reread hosts.tab 3893: # - All children connected to hosts that were removed from hosts.tab 3894: # are killed via SIGINT 3895: # - All children connected to previously existing hosts are sent SIGUSR1 3896: # - Our internal hosts hash is updated to reflect the new contents of 3897: # hosts.tab causing connections from hosts added to hosts.tab to 3898: # now be honored. 3899: # 3900: sub UpdateHosts { 3901: &status("Reload hosts.tab"); 3902: logthis(' Updating connections '); 3903: # 3904: # The %children hash has the set of IP's we currently have children 3905: # on. These need to be matched against records in the hosts.tab 3906: # Any ip's no longer in the table get killed off they correspond to 3907: # either dropped or changed hosts. Note that the re-read of the table 3908: # will take care of new and changed hosts as connections come into being. 3909: 3910: 3911: KillHostHashes; 3912: ReadHostTable; 3913: 3914: foreach my $child (keys %children) { 3915: my $childip = $children{$child}; 3916: if(!$hostid{$childip}) { 3917: logthis(' UpdateHosts killing child ' 3918: ." $child for ip $childip "); 3919: kill('INT', $child); 3920: } else { 3921: logthis(' keeping child for ip ' 3922: ." $childip (pid=$child) "); 3923: } 3924: } 3925: ReloadApache; 3926: &status("Finished reloading hosts.tab"); 3927: } 3928: 3929: 3930: sub checkchildren { 3931: &status("Checking on the children (sending signals)"); 3932: &initnewstatus(); 3933: &logstatus(); 3934: &logthis('Going to check on the children'); 3935: my $docdir=$perlvar{'lonDocRoot'}; 3936: foreach (sort keys %children) { 3937: #sleep 1; 3938: unless (kill 'USR1' => $_) { 3939: &logthis ('Child '.$_.' is dead'); 3940: &logstatus($$.' is dead'); 3941: delete($children{$_}); 3942: } 3943: } 3944: sleep 5; 3945: $SIG{ALRM} = sub { Debug("timeout"); 3946: die "timeout"; }; 3947: $SIG{__DIE__} = 'DEFAULT'; 3948: &status("Checking on the children (waiting for reports)"); 3949: foreach (sort keys %children) { 3950: unless (-e "$docdir/lon-status/londchld/$_.txt") { 3951: eval { 3952: alarm(300); 3953: &logthis('Child '.$_.' did not respond'); 3954: kill 9 => $_; 3955: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 3956: #$subj="LON: $currenthostid killed lond process $_"; 3957: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; 3958: #$execdir=$perlvar{'lonDaemons'}; 3959: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; 3960: delete($children{$_}); 3961: alarm(0); 3962: } 3963: } 3964: } 3965: $SIG{ALRM} = 'DEFAULT'; 3966: $SIG{__DIE__} = \&catchexception; 3967: &status("Finished checking children"); 3968: &logthis('Finished Checking children'); 3969: } 3970: 3971: # --------------------------------------------------------------------- Logging 3972: 3973: sub logthis { 3974: my $message=shift; 3975: my $execdir=$perlvar{'lonDaemons'}; 3976: my $fh=IO::File->new(">>$execdir/logs/lond.log"); 3977: my $now=time; 3978: my $local=localtime($now); 3979: $lastlog=$local.': '.$message; 3980: print $fh "$local ($$): $message\n"; 3981: } 3982: 3983: # ------------------------- Conditional log if $DEBUG true. 3984: sub Debug { 3985: my $message = shift; 3986: if($DEBUG) { 3987: &logthis($message); 3988: } 3989: } 3990: 3991: # 3992: # Sub to do replies to client.. this gives a hook for some 3993: # debug tracing too: 3994: # Parameters: 3995: # fd - File open on client. 3996: # reply - Text to send to client. 3997: # request - Original request from client. 3998: # 3999: sub Reply { 4000: my ($fd, $reply, $request) = @_; 4001: print $fd $reply; 4002: Debug("Request was $request Reply was $reply"); 4003: 4004: $Transactions++; 4005: 4006: 4007: } 4008: 4009: 4010: # 4011: # Sub to report a failure. 4012: # This function: 4013: # - Increments the failure statistic counters. 4014: # - Invokes Reply to send the error message to the client. 4015: # Parameters: 4016: # fd - File descriptor open on the client 4017: # reply - Reply text to emit. 4018: # request - The original request message (used by Reply 4019: # to debug if that's enabled. 4020: # Implicit outputs: 4021: # $Failures- The number of failures is incremented. 4022: # Reply (invoked here) sends a message to the 4023: # client: 4024: # 4025: sub Failure { 4026: my $fd = shift; 4027: my $reply = shift; 4028: my $request = shift; 4029: 4030: $Failures++; 4031: Reply($fd, $reply, $request); # That's simple eh? 4032: } 4033: # ------------------------------------------------------------------ Log status 4034: 4035: sub logstatus { 4036: &status("Doing logging"); 4037: my $docdir=$perlvar{'lonDocRoot'}; 4038: { 4039: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); 4040: print $fh $status."\n".$lastlog."\n".time."\n$keymode"; 4041: $fh->close(); 4042: } 4043: &status("Finished $$.txt"); 4044: { 4045: open(LOG,">>$docdir/lon-status/londstatus.txt"); 4046: flock(LOG,LOCK_EX); 4047: print LOG $$."\t".$clientname."\t".$currenthostid."\t" 4048: .$status."\t".$lastlog."\t $keymode\n"; 4049: flock(DB,LOCK_UN); 4050: close(LOG); 4051: } 4052: &status("Finished logging"); 4053: } 4054: 4055: sub initnewstatus { 4056: my $docdir=$perlvar{'lonDocRoot'}; 4057: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); 4058: my $now=time; 4059: my $local=localtime($now); 4060: print $fh "LOND status $local - parent $$\n\n"; 4061: opendir(DIR,"$docdir/lon-status/londchld"); 4062: while (my $filename=readdir(DIR)) { 4063: unlink("$docdir/lon-status/londchld/$filename"); 4064: } 4065: closedir(DIR); 4066: } 4067: 4068: # -------------------------------------------------------------- Status setting 4069: 4070: sub status { 4071: my $what=shift; 4072: my $now=time; 4073: my $local=localtime($now); 4074: $status=$local.': '.$what; 4075: $0='lond: '.$what.' '.$local; 4076: } 4077: 4078: # -------------------------------------------------------- Escape Special Chars 4079: 4080: sub escape { 4081: my $str=shift; 4082: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 4083: return $str; 4084: } 4085: 4086: # ----------------------------------------------------- Un-Escape Special Chars 4087: 4088: sub unescape { 4089: my $str=shift; 4090: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 4091: return $str; 4092: } 4093: 4094: # ----------------------------------------------------------- Send USR1 to lonc 4095: 4096: sub reconlonc { 4097: my $peerfile=shift; 4098: &logthis("Trying to reconnect for $peerfile"); 4099: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 4100: if (my $fh=IO::File->new("$loncfile")) { 4101: my $loncpid=<$fh>; 4102: chomp($loncpid); 4103: if (kill 0 => $loncpid) { 4104: &logthis("lonc at pid $loncpid responding, sending USR1"); 4105: kill USR1 => $loncpid; 4106: } else { 4107: &logthis( 4108: "CRITICAL: " 4109: ."lonc at pid $loncpid not responding, giving up"); 4110: } 4111: } else { 4112: &logthis('CRITICAL: lonc not running, giving up'); 4113: } 4114: } 4115: 4116: # -------------------------------------------------- Non-critical communication 4117: 4118: sub subreply { 4119: my ($cmd,$server)=@_; 4120: my $peerfile="$perlvar{'lonSockDir'}/$server"; 4121: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 4122: Type => SOCK_STREAM, 4123: Timeout => 10) 4124: or return "con_lost"; 4125: print $sclient "$cmd\n"; 4126: my $answer=<$sclient>; 4127: chomp($answer); 4128: if (!$answer) { $answer="con_lost"; } 4129: return $answer; 4130: } 4131: 4132: sub reply { 4133: my ($cmd,$server)=@_; 4134: my $answer; 4135: if ($server ne $currenthostid) { 4136: $answer=subreply($cmd,$server); 4137: if ($answer eq 'con_lost') { 4138: $answer=subreply("ping",$server); 4139: if ($answer ne $server) { 4140: &logthis("sub reply: answer != server answer is $answer, server is $server"); 4141: &reconlonc("$perlvar{'lonSockDir'}/$server"); 4142: } 4143: $answer=subreply($cmd,$server); 4144: } 4145: } else { 4146: $answer='self_reply'; 4147: } 4148: return $answer; 4149: } 4150: 4151: # -------------------------------------------------------------- Talk to lonsql 4152: 4153: sub sql_reply { 4154: my ($cmd)=@_; 4155: my $answer=&sub_sql_reply($cmd); 4156: if ($answer eq 'con_lost') { $answer=&sub_sql_reply($cmd); } 4157: return $answer; 4158: } 4159: 4160: sub sub_sql_reply { 4161: my ($cmd)=@_; 4162: my $unixsock="mysqlsock"; 4163: my $peerfile="$perlvar{'lonSockDir'}/$unixsock"; 4164: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 4165: Type => SOCK_STREAM, 4166: Timeout => 10) 4167: or return "con_lost"; 4168: print $sclient "$cmd\n"; 4169: my $answer=<$sclient>; 4170: chomp($answer); 4171: if (!$answer) { $answer="con_lost"; } 4172: return $answer; 4173: } 4174: 4175: # -------------------------------------------- Return path to profile directory 4176: 4177: sub propath { 4178: my ($udom,$uname)=@_; 4179: $udom=~s/\W//g; 4180: $uname=~s/\W//g; 4181: my $subdir=$uname.'__'; 4182: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 4183: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 4184: return $proname; 4185: } 4186: 4187: # --------------------------------------- Is this the home server of an author? 4188: 4189: sub ishome { 4190: my $author=shift; 4191: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 4192: my ($udom,$uname)=split(/\//,$author); 4193: my $proname=propath($udom,$uname); 4194: if (-e $proname) { 4195: return 'owner'; 4196: } else { 4197: return 'not_owner'; 4198: } 4199: } 4200: 4201: # ======================================================= Continue main program 4202: # ---------------------------------------------------- Fork once and dissociate 4203: 4204: my $fpid=fork; 4205: exit if $fpid; 4206: die "Couldn't fork: $!" unless defined ($fpid); 4207: 4208: POSIX::setsid() or die "Can't start new session: $!"; 4209: 4210: # ------------------------------------------------------- Write our PID on disk 4211: 4212: my $execdir=$perlvar{'lonDaemons'}; 4213: open (PIDSAVE,">$execdir/logs/lond.pid"); 4214: print PIDSAVE "$$\n"; 4215: close(PIDSAVE); 4216: &logthis("CRITICAL: ---------- Starting ----------"); 4217: &status('Starting'); 4218: 4219: 4220: 4221: # ----------------------------------------------------- Install signal handlers 4222: 4223: 4224: $SIG{CHLD} = \&REAPER; 4225: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 4226: $SIG{HUP} = \&HUPSMAN; 4227: $SIG{USR1} = \&checkchildren; 4228: $SIG{USR2} = \&UpdateHosts; 4229: 4230: # Read the host hashes: 4231: 4232: ReadHostTable; 4233: 4234: # -------------------------------------------------------------- 4235: # Accept connections. When a connection comes in, it is validated 4236: # and if good, a child process is created to process transactions 4237: # along the connection. 4238: 4239: while (1) { 4240: &status('Starting accept'); 4241: $client = $server->accept() or next; 4242: &status('Accepted '.$client.' off to spawn'); 4243: make_new_child($client); 4244: &status('Finished spawning'); 4245: } 4246: 4247: sub make_new_child { 4248: my $pid; 4249: # my $cipher; # Now global 4250: my $sigset; 4251: 4252: $client = shift; 4253: &status('Starting new child '.$client); 4254: &logthis(' Attempting to start child ('.$client. 4255: ")"); 4256: # block signal for fork 4257: $sigset = POSIX::SigSet->new(SIGINT); 4258: sigprocmask(SIG_BLOCK, $sigset) 4259: or die "Can't block SIGINT for fork: $!\n"; 4260: 4261: die "fork: $!" unless defined ($pid = fork); 4262: 4263: $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of 4264: # connection liveness. 4265: 4266: # 4267: # Figure out who we're talking to so we can record the peer in 4268: # the pid hash. 4269: # 4270: my $caller = getpeername($client); 4271: my ($port,$iaddr); 4272: if (defined($caller) && length($caller) > 0) { 4273: ($port,$iaddr)=unpack_sockaddr_in($caller); 4274: } else { 4275: &logthis("Unable to determine who caller was, getpeername returned nothing"); 4276: } 4277: if (defined($iaddr)) { 4278: $clientip = inet_ntoa($iaddr); 4279: Debug("Connected with $clientip"); 4280: $clientdns = gethostbyaddr($iaddr, AF_INET); 4281: Debug("Connected with $clientdns by name"); 4282: } else { 4283: &logthis("Unable to determine clientip"); 4284: $clientip='Unavailable'; 4285: } 4286: 4287: if ($pid) { 4288: # Parent records the child's birth and returns. 4289: sigprocmask(SIG_UNBLOCK, $sigset) 4290: or die "Can't unblock SIGINT for fork: $!\n"; 4291: $children{$pid} = $clientip; 4292: &status('Started child '.$pid); 4293: return; 4294: } else { 4295: # Child can *not* return from this subroutine. 4296: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before 4297: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns 4298: #don't get intercepted 4299: $SIG{USR1}= \&logstatus; 4300: $SIG{ALRM}= \&timeout; 4301: $lastlog='Forked '; 4302: $status='Forked'; 4303: 4304: # unblock signals 4305: sigprocmask(SIG_UNBLOCK, $sigset) 4306: or die "Can't unblock SIGINT for fork: $!\n"; 4307: 4308: # my $tmpsnum=0; # Now global 4309: #---------------------------------------------------- kerberos 5 initialization 4310: &Authen::Krb5::init_context(); 4311: &Authen::Krb5::init_ets(); 4312: 4313: &status('Accepted connection'); 4314: # ============================================================================= 4315: # do something with the connection 4316: # ----------------------------------------------------------------------------- 4317: # see if we know client and 'check' for spoof IP by ineffective challenge 4318: 4319: ReadManagerTable; # May also be a manager!! 4320: 4321: my $clientrec=($hostid{$clientip} ne undef); 4322: my $ismanager=($managers{$clientip} ne undef); 4323: $clientname = "[unknonwn]"; 4324: if($clientrec) { # Establish client type. 4325: $ConnectionType = "client"; 4326: $clientname = $hostid{$clientip}; 4327: if($ismanager) { 4328: $ConnectionType = "both"; 4329: } 4330: } else { 4331: $ConnectionType = "manager"; 4332: $clientname = $managers{$clientip}; 4333: } 4334: my $clientok; 4335: 4336: if ($clientrec || $ismanager) { 4337: &status("Waiting for init from $clientip $clientname"); 4338: &logthis('INFO: Connection, '. 4339: $clientip. 4340: " ($clientname) connection type = $ConnectionType " ); 4341: &status("Connecting $clientip ($clientname))"); 4342: my $remotereq=<$client>; 4343: chomp($remotereq); 4344: Debug("Got init: $remotereq"); 4345: my $inikeyword = split(/:/, $remotereq); 4346: if ($remotereq =~ /^init/) { 4347: &sethost("sethost:$perlvar{'lonHostID'}"); 4348: # 4349: # If the remote is attempting a local init... give that a try: 4350: # 4351: my ($i, $inittype) = split(/:/, $remotereq); 4352: 4353: # If the connection type is ssl, but I didn't get my 4354: # certificate files yet, then I'll drop back to 4355: # insecure (if allowed). 4356: 4357: if($inittype eq "ssl") { 4358: my ($ca, $cert) = lonssl::CertificateFile; 4359: my $kfile = lonssl::KeyFile; 4360: if((!$ca) || 4361: (!$cert) || 4362: (!$kfile)) { 4363: $inittype = ""; # This forces insecure attempt. 4364: &logthis(" Certificates not " 4365: ."installed -- trying insecure auth"); 4366: } else { # SSL certificates are in place so 4367: } # Leave the inittype alone. 4368: } 4369: 4370: if($inittype eq "local") { 4371: my $key = LocalConnection($client, $remotereq); 4372: if($key) { 4373: Debug("Got local key $key"); 4374: $clientok = 1; 4375: my $cipherkey = pack("H32", $key); 4376: $cipher = new IDEA($cipherkey); 4377: print $client "ok:local\n"; 4378: &logthis('"); 4380: $keymode = "local" 4381: } else { 4382: Debug("Failed to get local key"); 4383: $clientok = 0; 4384: shutdown($client, 3); 4385: close $client; 4386: } 4387: } elsif ($inittype eq "ssl") { 4388: my $key = SSLConnection($client); 4389: if ($key) { 4390: $clientok = 1; 4391: my $cipherkey = pack("H32", $key); 4392: $cipher = new IDEA($cipherkey); 4393: &logthis('' 4394: ."Successfull ssl authentication with $clientname "); 4395: $keymode = "ssl"; 4396: 4397: } else { 4398: $clientok = 0; 4399: close $client; 4400: } 4401: 4402: } else { 4403: my $ok = InsecureConnection($client); 4404: if($ok) { 4405: $clientok = 1; 4406: &logthis('' 4407: ."Successful insecure authentication with $clientname "); 4408: print $client "ok\n"; 4409: $keymode = "insecure"; 4410: } else { 4411: &logthis('' 4412: ."Attempted insecure connection disallowed "); 4413: close $client; 4414: $clientok = 0; 4415: 4416: } 4417: } 4418: } else { 4419: &logthis( 4420: "WARNING: " 4421: ."$clientip failed to initialize: >$remotereq< "); 4422: &status('No init '.$clientip); 4423: } 4424: 4425: } else { 4426: &logthis( 4427: "WARNING: Unknown client $clientip"); 4428: &status('Hung up on '.$clientip); 4429: } 4430: 4431: if ($clientok) { 4432: # ---------------- New known client connecting, could mean machine online again 4433: 4434: foreach my $id (keys(%hostip)) { 4435: if ($hostip{$id} ne $clientip || 4436: $hostip{$currenthostid} eq $clientip) { 4437: # no need to try to do recon's to myself 4438: next; 4439: } 4440: &reconlonc("$perlvar{'lonSockDir'}/$id"); 4441: } 4442: &logthis("Established connection: $clientname"); 4443: &status('Will listen to '.$clientname); 4444: # ------------------------------------------------------------ Process requests 4445: my $keep_going = 1; 4446: my $user_input; 4447: while(($user_input = get_request) && $keep_going) { 4448: alarm(120); 4449: Debug("Main: Got $user_input\n"); 4450: $keep_going = &process_request($user_input); 4451: alarm(0); 4452: &status('Listening to '.$clientname." ($keymode)"); 4453: } 4454: 4455: # --------------------------------------------- client unknown or fishy, refuse 4456: } else { 4457: print $client "refused\n"; 4458: $client->close(); 4459: &logthis("WARNING: " 4460: ."Rejected client $clientip, closing connection"); 4461: } 4462: } 4463: 4464: # ============================================================================= 4465: 4466: &logthis("CRITICAL: " 4467: ."Disconnect from $clientip ($clientname)"); 4468: 4469: 4470: # this exit is VERY important, otherwise the child will become 4471: # a producer of more and more children, forking yourself into 4472: # process death. 4473: exit; 4474: 4475: } 4476: 4477: 4478: # 4479: # Checks to see if the input roleput request was to set 4480: # an author role. If so, invokes the lchtmldir script to set 4481: # up a correct public_html 4482: # Parameters: 4483: # request - The request sent to the rolesput subchunk. 4484: # We're looking for /domain/_au 4485: # domain - The domain in which the user is having roles doctored. 4486: # user - Name of the user for which the role is being put. 4487: # authtype - The authentication type associated with the user. 4488: # 4489: sub manage_permissions 4490: { 4491: 4492: my ($request, $domain, $user, $authtype) = @_; 4493: 4494: # See if the request is of the form /$domain/_au 4495: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... 4496: my $execdir = $perlvar{'lonDaemons'}; 4497: my $userhome= "/home/$user" ; 4498: &logthis("system $execdir/lchtmldir $userhome $user $authtype"); 4499: system("$execdir/lchtmldir $userhome $user $authtype"); 4500: } 4501: } 4502: 4503: 4504: # 4505: # Return the full path of a user password file, whether it exists or not. 4506: # Parameters: 4507: # domain - Domain in which the password file lives. 4508: # user - name of the user. 4509: # Returns: 4510: # Full passwd path: 4511: # 4512: sub password_path { 4513: my ($domain, $user) = @_; 4514: 4515: 4516: my $path = &propath($domain, $user); 4517: $path .= "/passwd"; 4518: 4519: return $path; 4520: } 4521: 4522: # Password Filename 4523: # Returns the path to a passwd file given domain and user... only if 4524: # it exists. 4525: # Parameters: 4526: # domain - Domain in which to search. 4527: # user - username. 4528: # Returns: 4529: # - If the password file exists returns its path. 4530: # - If the password file does not exist, returns undefined. 4531: # 4532: sub password_filename { 4533: my ($domain, $user) = @_; 4534: 4535: Debug ("PasswordFilename called: dom = $domain user = $user"); 4536: 4537: my $path = &password_path($domain, $user); 4538: Debug("PasswordFilename got path: $path"); 4539: if(-e $path) { 4540: return $path; 4541: } else { 4542: return undef; 4543: } 4544: } 4545: 4546: # 4547: # Rewrite the contents of the user's passwd file. 4548: # Parameters: 4549: # domain - domain of the user. 4550: # name - User's name. 4551: # contents - New contents of the file. 4552: # Returns: 4553: # 0 - Failed. 4554: # 1 - Success. 4555: # 4556: sub rewrite_password_file { 4557: my ($domain, $user, $contents) = @_; 4558: 4559: my $file = &password_filename($domain, $user); 4560: if (defined $file) { 4561: my $pf = IO::File->new(">$file"); 4562: if($pf) { 4563: print $pf "$contents\n"; 4564: return 1; 4565: } else { 4566: return 0; 4567: } 4568: } else { 4569: return 0; 4570: } 4571: 4572: } 4573: 4574: # 4575: # get_auth_type - Determines the authorization type of a user in a domain. 4576: 4577: # Returns the authorization type or nouser if there is no such user. 4578: # 4579: sub get_auth_type 4580: { 4581: 4582: my ($domain, $user) = @_; 4583: 4584: Debug("get_auth_type( $domain, $user ) \n"); 4585: my $proname = &propath($domain, $user); 4586: my $passwdfile = "$proname/passwd"; 4587: if( -e $passwdfile ) { 4588: my $pf = IO::File->new($passwdfile); 4589: my $realpassword = <$pf>; 4590: chomp($realpassword); 4591: Debug("Password info = $realpassword\n"); 4592: my ($authtype, $contentpwd) = split(/:/, $realpassword); 4593: Debug("Authtype = $authtype, content = $contentpwd\n"); 4594: my $availinfo = ''; 4595: if($authtype eq 'krb4' or $authtype eq 'krb5') { 4596: $availinfo = $contentpwd; 4597: } 4598: 4599: return "$authtype:$availinfo"; 4600: } else { 4601: Debug("Returning nouser"); 4602: return "nouser"; 4603: } 4604: } 4605: 4606: # 4607: # Validate a user given their domain, name and password. This utility 4608: # function is used by both AuthenticateHandler and ChangePasswordHandler 4609: # to validate the login credentials of a user. 4610: # Parameters: 4611: # $domain - The domain being logged into (this is required due to 4612: # the capability for multihomed systems. 4613: # $user - The name of the user being validated. 4614: # $password - The user's propoposed password. 4615: # 4616: # Returns: 4617: # 1 - The domain,user,pasword triplet corresponds to a valid 4618: # user. 4619: # 0 - The domain,user,password triplet is not a valid user. 4620: # 4621: sub validate_user { 4622: my ($domain, $user, $password) = @_; 4623: 4624: 4625: # Why negative ~pi you may well ask? Well this function is about 4626: # authentication, and therefore very important to get right. 4627: # I've initialized the flag that determines whether or not I've 4628: # validated correctly to a value it's not supposed to get. 4629: # At the end of this function. I'll ensure that it's not still that 4630: # value so we don't just wind up returning some accidental value 4631: # as a result of executing an unforseen code path that 4632: # did not set $validated. 4633: 4634: my $validated = -3.14159; 4635: 4636: # How we authenticate is determined by the type of authentication 4637: # the user has been assigned. If the authentication type is 4638: # "nouser", the user does not exist so we will return 0. 4639: 4640: my $contents = &get_auth_type($domain, $user); 4641: my ($howpwd, $contentpwd) = split(/:/, $contents); 4642: 4643: my $null = pack("C",0); # Used by kerberos auth types. 4644: 4645: if ($howpwd ne 'nouser') { 4646: 4647: if($howpwd eq "internal") { # Encrypted is in local password file. 4648: $validated = (crypt($password, $contentpwd) eq $contentpwd); 4649: } 4650: elsif ($howpwd eq "unix") { # User is a normal unix user. 4651: $contentpwd = (getpwnam($user))[1]; 4652: if($contentpwd) { 4653: if($contentpwd eq 'x') { # Shadow password file... 4654: my $pwauth_path = "/usr/local/sbin/pwauth"; 4655: open PWAUTH, "|$pwauth_path" or 4656: die "Cannot invoke authentication"; 4657: print PWAUTH "$user\n$password\n"; 4658: close PWAUTH; 4659: $validated = ! $?; 4660: 4661: } else { # Passwords in /etc/passwd. 4662: $validated = (crypt($password, 4663: $contentpwd) eq $contentpwd); 4664: } 4665: } else { 4666: $validated = 0; 4667: } 4668: } 4669: elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain. 4670: if(! ($password =~ /$null/) ) { 4671: my $k4error = &Authen::Krb4::get_pw_in_tkt($user, 4672: "", 4673: $contentpwd,, 4674: 'krbtgt', 4675: $contentpwd, 4676: 1, 4677: $password); 4678: if(!$k4error) { 4679: $validated = 1; 4680: } else { 4681: $validated = 0; 4682: &logthis('krb4: '.$user.', '.$contentpwd.', '. 4683: &Authen::Krb4::get_err_txt($Authen::Krb4::error)); 4684: } 4685: } else { 4686: $validated = 0; # Password has a match with null. 4687: } 4688: } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain. 4689: if(!($password =~ /$null/)) { # Null password not allowed. 4690: my $krbclient = &Authen::Krb5::parse_name($user.'@' 4691: .$contentpwd); 4692: my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd; 4693: my $krbserver = &Authen::Krb5::parse_name($krbservice); 4694: my $credentials= &Authen::Krb5::cc_default(); 4695: $credentials->initialize($krbclient); 4696: my $krbreturn = &Authen::KRb5::get_in_tkt_with_password($krbclient, 4697: $krbserver, 4698: $password, 4699: $credentials); 4700: $validated = ($krbreturn == 1); 4701: } else { 4702: $validated = 0; 4703: } 4704: } elsif ($howpwd eq "localauth") { 4705: # Authenticate via installation specific authentcation method: 4706: $validated = &localauth::localauth($user, 4707: $password, 4708: $contentpwd); 4709: } else { # Unrecognized auth is also bad. 4710: $validated = 0; 4711: } 4712: } else { 4713: $validated = 0; 4714: } 4715: # 4716: # $validated has the correct stat of the authentication: 4717: # 4718: 4719: unless ($validated != -3.14159) { 4720: die "ValidateUser - failed to set the value of validated"; 4721: } 4722: return $validated; 4723: } 4724: 4725: 4726: sub addline { 4727: my ($fname,$hostid,$ip,$newline)=@_; 4728: my $contents; 4729: my $found=0; 4730: my $expr='^'.$hostid.':'.$ip.':'; 4731: $expr =~ s/\./\\\./g; 4732: my $sh; 4733: if ($sh=IO::File->new("$fname.subscription")) { 4734: while (my $subline=<$sh>) { 4735: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} 4736: } 4737: $sh->close(); 4738: } 4739: $sh=IO::File->new(">$fname.subscription"); 4740: if ($contents) { print $sh $contents; } 4741: if ($newline) { print $sh $newline; } 4742: $sh->close(); 4743: return $found; 4744: } 4745: 4746: sub get_chat { 4747: my ($cdom,$cname,$udom,$uname)=@_; 4748: my %hash; 4749: my $proname=&propath($cdom,$cname); 4750: my @entries=(); 4751: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", 4752: &GDBM_READER(),0640)) { 4753: @entries=map { $_.':'.$hash{$_} } sort keys %hash; 4754: untie %hash; 4755: } 4756: my @participants=(); 4757: my $cutoff=time-60; 4758: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", 4759: &GDBM_WRCREAT(),0640)) { 4760: $hash{$uname.':'.$udom}=time; 4761: foreach (sort keys %hash) { 4762: if ($hash{$_}>$cutoff) { 4763: $participants[$#participants+1]='active_participant:'.$_; 4764: } 4765: } 4766: untie %hash; 4767: } 4768: return (@participants,@entries); 4769: } 4770: 4771: sub chat_add { 4772: my ($cdom,$cname,$newchat)=@_; 4773: my %hash; 4774: my $proname=&propath($cdom,$cname); 4775: my @entries=(); 4776: my $time=time; 4777: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", 4778: &GDBM_WRCREAT(),0640)) { 4779: @entries=map { $_.':'.$hash{$_} } sort keys %hash; 4780: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); 4781: my ($thentime,$idnum)=split(/\_/,$lastid); 4782: my $newid=$time.'_000000'; 4783: if ($thentime==$time) { 4784: $idnum=~s/^0+//; 4785: $idnum++; 4786: $idnum=substr('000000'.$idnum,-6,6); 4787: $newid=$time.'_'.$idnum; 4788: } 4789: $hash{$newid}=$newchat; 4790: my $expired=$time-3600; 4791: foreach (keys %hash) { 4792: my ($thistime)=($_=~/(\d+)\_/); 4793: if ($thistime<$expired) { 4794: delete $hash{$_}; 4795: } 4796: } 4797: untie %hash; 4798: } 4799: { 4800: my $hfh; 4801: if ($hfh=IO::File->new(">>$proname/chatroom.log")) { 4802: print $hfh "$time:".&unescape($newchat)."\n"; 4803: } 4804: } 4805: } 4806: 4807: sub unsub { 4808: my ($fname,$clientip)=@_; 4809: my $result; 4810: my $unsubs = 0; # Number of successful unsubscribes: 4811: 4812: 4813: # An old way subscriptions were handled was to have a 4814: # subscription marker file: 4815: 4816: Debug("Attempting unlink of $fname.$clientname"); 4817: if (unlink("$fname.$clientname")) { 4818: $unsubs++; # Successful unsub via marker file. 4819: } 4820: 4821: # The more modern way to do it is to have a subscription list 4822: # file: 4823: 4824: if (-e "$fname.subscription") { 4825: my $found=&addline($fname,$clientname,$clientip,''); 4826: if ($found) { 4827: $unsubs++; 4828: } 4829: } 4830: 4831: # If either or both of these mechanisms succeeded in unsubscribing a 4832: # resource we can return ok: 4833: 4834: if($unsubs) { 4835: $result = "ok\n"; 4836: } else { 4837: $result = "not_subscribed\n"; 4838: } 4839: 4840: return $result; 4841: } 4842: 4843: sub currentversion { 4844: my $fname=shift; 4845: my $version=-1; 4846: my $ulsdir=''; 4847: if ($fname=~/^(.+)\/[^\/]+$/) { 4848: $ulsdir=$1; 4849: } 4850: my ($fnamere1,$fnamere2); 4851: # remove version if already specified 4852: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; 4853: # get the bits that go before and after the version number 4854: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { 4855: $fnamere1=$1; 4856: $fnamere2='.'.$2; 4857: } 4858: if (-e $fname) { $version=1; } 4859: if (-e $ulsdir) { 4860: if(-d $ulsdir) { 4861: if (opendir(LSDIR,$ulsdir)) { 4862: my $ulsfn; 4863: while ($ulsfn=readdir(LSDIR)) { 4864: # see if this is a regular file (ignore links produced earlier) 4865: my $thisfile=$ulsdir.'/'.$ulsfn; 4866: unless (-l $thisfile) { 4867: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) { 4868: if ($1>$version) { $version=$1; } 4869: } 4870: } 4871: } 4872: closedir(LSDIR); 4873: $version++; 4874: } 4875: } 4876: } 4877: return $version; 4878: } 4879: 4880: sub thisversion { 4881: my $fname=shift; 4882: my $version=-1; 4883: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { 4884: $version=$1; 4885: } 4886: return $version; 4887: } 4888: 4889: sub subscribe { 4890: my ($userinput,$clientip)=@_; 4891: my $result; 4892: my ($cmd,$fname)=split(/:/,$userinput); 4893: my $ownership=&ishome($fname); 4894: if ($ownership eq 'owner') { 4895: # explitly asking for the current version? 4896: unless (-e $fname) { 4897: my $currentversion=&currentversion($fname); 4898: if (&thisversion($fname)==$currentversion) { 4899: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { 4900: my $root=$1; 4901: my $extension=$2; 4902: symlink($root.'.'.$extension, 4903: $root.'.'.$currentversion.'.'.$extension); 4904: unless ($extension=~/\.meta$/) { 4905: symlink($root.'.'.$extension.'.meta', 4906: $root.'.'.$currentversion.'.'.$extension.'.meta'); 4907: } 4908: } 4909: } 4910: } 4911: if (-e $fname) { 4912: if (-d $fname) { 4913: $result="directory\n"; 4914: } else { 4915: if (-e "$fname.$clientname") {&unsub($fname,$clientip);} 4916: my $now=time; 4917: my $found=&addline($fname,$clientname,$clientip, 4918: "$clientname:$clientip:$now\n"); 4919: if ($found) { $result="$fname\n"; } 4920: # if they were subscribed to only meta data, delete that 4921: # subscription, when you subscribe to a file you also get 4922: # the metadata 4923: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } 4924: $fname=~s/\/home\/httpd\/html\/res/raw/; 4925: $fname="http://$thisserver/".$fname; 4926: $result="$fname\n"; 4927: } 4928: } else { 4929: $result="not_found\n"; 4930: } 4931: } else { 4932: $result="rejected\n"; 4933: } 4934: return $result; 4935: } 4936: 4937: sub make_passwd_file { 4938: my ($uname, $umode,$npass,$passfilename)=@_; 4939: my $result="ok\n"; 4940: if ($umode eq 'krb4' or $umode eq 'krb5') { 4941: { 4942: my $pf = IO::File->new(">$passfilename"); 4943: print $pf "$umode:$npass\n"; 4944: } 4945: } elsif ($umode eq 'internal') { 4946: my $salt=time; 4947: $salt=substr($salt,6,2); 4948: my $ncpass=crypt($npass,$salt); 4949: { 4950: &Debug("Creating internal auth"); 4951: my $pf = IO::File->new(">$passfilename"); 4952: print $pf "internal:$ncpass\n"; 4953: } 4954: } elsif ($umode eq 'localauth') { 4955: { 4956: my $pf = IO::File->new(">$passfilename"); 4957: print $pf "localauth:$npass\n"; 4958: } 4959: } elsif ($umode eq 'unix') { 4960: { 4961: # 4962: # Don't allow the creation of privileged accounts!!! that would 4963: # be real bad!!! 4964: # 4965: my $uid = getpwnam($uname); 4966: if((defined $uid) && ($uid == 0)) { 4967: &logthis(">>>Attempted to create privilged account blocked"); 4968: return "no_priv_account_error\n"; 4969: } 4970: 4971: my $execpath ="$perlvar{'lonDaemons'}/"."lcuseradd"; 4972: 4973: my $lc_error_file = $execdir."/tmp/lcuseradd".$$.".status"; 4974: { 4975: &Debug("Executing external: ".$execpath); 4976: &Debug("user = ".$uname.", Password =". $npass); 4977: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); 4978: print $se "$uname\n"; 4979: print $se "$npass\n"; 4980: print $se "$npass\n"; 4981: print $se "$lc_error_file\n"; # Status -> unique file. 4982: } 4983: my $error = IO::File->new("< $lc_error_file"); 4984: my $useraddok = <$error>; 4985: $error->close; 4986: unlink($lc_error_file); 4987: 4988: chomp $useraddok; 4989: 4990: if($useraddok > 0) { 4991: my $error_text = &lcuseraddstrerror($useraddok); 4992: &logthis("Failed lcuseradd: $error_text"); 4993: $result = "lcuseradd_failed:$error_text\n"; 4994: } else { 4995: my $pf = IO::File->new(">$passfilename"); 4996: print $pf "unix:\n"; 4997: } 4998: } 4999: } elsif ($umode eq 'none') { 5000: { 5001: my $pf = IO::File->new("> $passfilename"); 5002: print $pf "none:\n"; 5003: } 5004: } else { 5005: $result="auth_mode_error\n"; 5006: } 5007: return $result; 5008: } 5009: 5010: sub sethost { 5011: my ($remotereq) = @_; 5012: my (undef,$hostid)=split(/:/,$remotereq); 5013: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } 5014: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { 5015: $currenthostid =$hostid; 5016: $currentdomainid=$hostdom{$hostid}; 5017: &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); 5018: } else { 5019: &logthis("Requested host id $hostid not an alias of ". 5020: $perlvar{'lonHostID'}." refusing connection"); 5021: return 'unable_to_set'; 5022: } 5023: return 'ok'; 5024: } 5025: 5026: sub version { 5027: my ($userinput)=@_; 5028: $remoteVERSION=(split(/:/,$userinput))[1]; 5029: return "version:$VERSION"; 5030: } 5031: 5032: #There is a copy of this in lonnet.pm 5033: sub userload { 5034: my $numusers=0; 5035: { 5036: opendir(LONIDS,$perlvar{'lonIDsDir'}); 5037: my $filename; 5038: my $curtime=time; 5039: while ($filename=readdir(LONIDS)) { 5040: if ($filename eq '.' || $filename eq '..') {next;} 5041: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; 5042: if ($curtime-$mtime < 1800) { $numusers++; } 5043: } 5044: closedir(LONIDS); 5045: } 5046: my $userloadpercent=0; 5047: my $maxuserload=$perlvar{'lonUserLoadLim'}; 5048: if ($maxuserload) { 5049: $userloadpercent=100*$numusers/$maxuserload; 5050: } 5051: $userloadpercent=sprintf("%.2f",$userloadpercent); 5052: return $userloadpercent; 5053: } 5054: 5055: # Routines for serializing arrays and hashes (copies from lonnet) 5056: 5057: sub array2str { 5058: my (@array) = @_; 5059: my $result=&arrayref2str(\@array); 5060: $result=~s/^__ARRAY_REF__//; 5061: $result=~s/__END_ARRAY_REF__$//; 5062: return $result; 5063: } 5064: 5065: sub arrayref2str { 5066: my ($arrayref) = @_; 5067: my $result='__ARRAY_REF__'; 5068: foreach my $elem (@$arrayref) { 5069: if(ref($elem) eq 'ARRAY') { 5070: $result.=&arrayref2str($elem).'&'; 5071: } elsif(ref($elem) eq 'HASH') { 5072: $result.=&hashref2str($elem).'&'; 5073: } elsif(ref($elem)) { 5074: #print("Got a ref of ".(ref($elem))." skipping."); 5075: } else { 5076: $result.=&escape($elem).'&'; 5077: } 5078: } 5079: $result=~s/\&$//; 5080: $result .= '__END_ARRAY_REF__'; 5081: return $result; 5082: } 5083: 5084: sub hash2str { 5085: my (%hash) = @_; 5086: my $result=&hashref2str(\%hash); 5087: $result=~s/^__HASH_REF__//; 5088: $result=~s/__END_HASH_REF__$//; 5089: return $result; 5090: } 5091: 5092: sub hashref2str { 5093: my ($hashref)=@_; 5094: my $result='__HASH_REF__'; 5095: foreach (sort(keys(%$hashref))) { 5096: if (ref($_) eq 'ARRAY') { 5097: $result.=&arrayref2str($_).'='; 5098: } elsif (ref($_) eq 'HASH') { 5099: $result.=&hashref2str($_).'='; 5100: } elsif (ref($_)) { 5101: $result.='='; 5102: #print("Got a ref of ".(ref($_))." skipping."); 5103: } else { 5104: if ($_) {$result.=&escape($_).'=';} else { last; } 5105: } 5106: 5107: if(ref($hashref->{$_}) eq 'ARRAY') { 5108: $result.=&arrayref2str($hashref->{$_}).'&'; 5109: } elsif(ref($hashref->{$_}) eq 'HASH') { 5110: $result.=&hashref2str($hashref->{$_}).'&'; 5111: } elsif(ref($hashref->{$_})) { 5112: $result.='&'; 5113: #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); 5114: } else { 5115: $result.=&escape($hashref->{$_}).'&'; 5116: } 5117: } 5118: $result=~s/\&$//; 5119: $result .= '__END_HASH_REF__'; 5120: return $result; 5121: } 5122: 5123: # ----------------------------------- POD (plain old documentation, CPAN style) 5124: 5125: =head1 NAME 5126: 5127: lond - "LON Daemon" Server (port "LOND" 5663) 5128: 5129: =head1 SYNOPSIS 5130: 5131: Usage: B<lond> 5132: 5133: Should only be run as user=www. This is a command-line script which 5134: is invoked by B<loncron>. There is no expectation that a typical user 5135: will manually start B<lond> from the command-line. (In other words, 5136: DO NOT START B<lond> YOURSELF.) 5137: 5138: =head1 DESCRIPTION 5139: 5140: There are two characteristics associated with the running of B<lond>, 5141: PROCESS MANAGEMENT (starting, stopping, handling child processes) 5142: and SERVER-SIDE ACTIVITIES (password authentication, user creation, 5143: subscriptions, etc). These are described in two large 5144: sections below. 5145: 5146: B<PROCESS MANAGEMENT> 5147: 5148: Preforker - server who forks first. Runs as a daemon. HUPs. 5149: Uses IDEA encryption 5150: 5151: B<lond> forks off children processes that correspond to the other servers 5152: in the network. Management of these processes can be done at the 5153: parent process level or the child process level. 5154: 5155: B<logs/lond.log> is the location of log messages. 5156: 5157: The process management is now explained in terms of linux shell commands, 5158: subroutines internal to this code, and signal assignments: 5159: 5160: =over 4 5161: 5162: =item * 5163: 5164: PID is stored in B<logs/lond.pid> 5165: 5166: This is the process id number of the parent B<lond> process. 5167: 5168: =item * 5169: 5170: SIGTERM and SIGINT 5171: 5172: Parent signal assignment: 5173: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 5174: 5175: Child signal assignment: 5176: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) 5177: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber 5178: to restart a new child.) 5179: 5180: Command-line invocations: 5181: B<kill> B<-s> SIGTERM I<PID> 5182: B<kill> B<-s> SIGINT I<PID> 5183: 5184: Subroutine B<HUNTSMAN>: 5185: This is only invoked for the B<lond> parent I<PID>. 5186: This kills all the children, and then the parent. 5187: The B<lonc.pid> file is cleared. 5188: 5189: =item * 5190: 5191: SIGHUP 5192: 5193: Current bug: 5194: This signal can only be processed the first time 5195: on the parent process. Subsequent SIGHUP signals 5196: have no effect. 5197: 5198: Parent signal assignment: 5199: $SIG{HUP} = \&HUPSMAN; 5200: 5201: Child signal assignment: 5202: none (nothing happens) 5203: 5204: Command-line invocations: 5205: B<kill> B<-s> SIGHUP I<PID> 5206: 5207: Subroutine B<HUPSMAN>: 5208: This is only invoked for the B<lond> parent I<PID>, 5209: This kills all the children, and then the parent. 5210: The B<lond.pid> file is cleared. 5211: 5212: =item * 5213: 5214: SIGUSR1 5215: 5216: Parent signal assignment: 5217: $SIG{USR1} = \&USRMAN; 5218: 5219: Child signal assignment: 5220: $SIG{USR1}= \&logstatus; 5221: 5222: Command-line invocations: 5223: B<kill> B<-s> SIGUSR1 I<PID> 5224: 5225: Subroutine B<USRMAN>: 5226: When invoked for the B<lond> parent I<PID>, 5227: SIGUSR1 is sent to all the children, and the status of 5228: each connection is logged. 5229: 5230: =item * 5231: 5232: SIGUSR2 5233: 5234: Parent Signal assignment: 5235: $SIG{USR2} = \&UpdateHosts 5236: 5237: Child signal assignment: 5238: NONE 5239: 5240: 5241: =item * 5242: 5243: SIGCHLD 5244: 5245: Parent signal assignment: 5246: $SIG{CHLD} = \&REAPER; 5247: 5248: Child signal assignment: 5249: none 5250: 5251: Command-line invocations: 5252: B<kill> B<-s> SIGCHLD I<PID> 5253: 5254: Subroutine B<REAPER>: 5255: This is only invoked for the B<lond> parent I<PID>. 5256: Information pertaining to the child is removed. 5257: The socket port is cleaned up. 5258: 5259: =back 5260: 5261: B<SERVER-SIDE ACTIVITIES> 5262: 5263: Server-side information can be accepted in an encrypted or non-encrypted 5264: method. 5265: 5266: =over 4 5267: 5268: =item ping 5269: 5270: Query a client in the hosts.tab table; "Are you there?" 5271: 5272: =item pong 5273: 5274: Respond to a ping query. 5275: 5276: =item ekey 5277: 5278: Read in encrypted key, make cipher. Respond with a buildkey. 5279: 5280: =item load 5281: 5282: Respond with CPU load based on a computation upon /proc/loadavg. 5283: 5284: =item currentauth 5285: 5286: Reply with current authentication information (only over an 5287: encrypted channel). 5288: 5289: =item auth 5290: 5291: Only over an encrypted channel, reply as to whether a user's 5292: authentication information can be validated. 5293: 5294: =item passwd 5295: 5296: Allow for a password to be set. 5297: 5298: =item makeuser 5299: 5300: Make a user. 5301: 5302: =item passwd 5303: 5304: Allow for authentication mechanism and password to be changed. 5305: 5306: =item home 5307: 5308: Respond to a question "are you the home for a given user?" 5309: 5310: =item update 5311: 5312: Update contents of a subscribed resource. 5313: 5314: =item unsubscribe 5315: 5316: The server is unsubscribing from a resource. 5317: 5318: =item subscribe 5319: 5320: The server is subscribing to a resource. 5321: 5322: =item log 5323: 5324: Place in B<logs/lond.log> 5325: 5326: =item put 5327: 5328: stores hash in namespace 5329: 5330: =item rolesputy 5331: 5332: put a role into a user's environment 5333: 5334: =item get 5335: 5336: returns hash with keys from array 5337: reference filled in from namespace 5338: 5339: =item eget 5340: 5341: returns hash with keys from array 5342: reference filled in from namesp (encrypts the return communication) 5343: 5344: =item rolesget 5345: 5346: get a role from a user's environment 5347: 5348: =item del 5349: 5350: deletes keys out of array from namespace 5351: 5352: =item keys 5353: 5354: returns namespace keys 5355: 5356: =item dump 5357: 5358: dumps the complete (or key matching regexp) namespace into a hash 5359: 5360: =item store 5361: 5362: stores hash permanently 5363: for this url; hashref needs to be given and should be a \%hashname; the 5364: remaining args aren't required and if they aren't passed or are '' they will 5365: be derived from the ENV 5366: 5367: =item restore 5368: 5369: returns a hash for a given url 5370: 5371: =item querysend 5372: 5373: Tells client about the lonsql process that has been launched in response 5374: to a sent query. 5375: 5376: =item queryreply 5377: 5378: Accept information from lonsql and make appropriate storage in temporary 5379: file space. 5380: 5381: =item idput 5382: 5383: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers 5384: for each student, defined perhaps by the institutional Registrar.) 5385: 5386: =item idget 5387: 5388: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers 5389: for each student, defined perhaps by the institutional Registrar.) 5390: 5391: =item tmpput 5392: 5393: Accept and store information in temporary space. 5394: 5395: =item tmpget 5396: 5397: Send along temporarily stored information. 5398: 5399: =item ls 5400: 5401: List part of a user's directory. 5402: 5403: =item pushtable 5404: 5405: Pushes a file in /home/httpd/lonTab directory. Currently limited to: 5406: hosts.tab and domain.tab. The old file is copied to *.tab.backup but 5407: must be restored manually in case of a problem with the new table file. 5408: pushtable requires that the request be encrypted and validated via 5409: ValidateManager. The form of the command is: 5410: enc:pushtable tablename <tablecontents> \n 5411: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a 5412: cleartext newline. 5413: 5414: =item Hanging up (exit or init) 5415: 5416: What to do when a client tells the server that they (the client) 5417: are leaving the network. 5418: 5419: =item unknown command 5420: 5421: If B<lond> is sent an unknown command (not in the list above), 5422: it replys to the client "unknown_cmd". 5423: 5424: 5425: =item UNKNOWN CLIENT 5426: 5427: If the anti-spoofing algorithm cannot verify the client, 5428: the client is rejected (with a "refused" message sent 5429: to the client, and the connection is closed. 5430: 5431: =back 5432: 5433: =head1 PREREQUISITES 5434: 5435: IO::Socket 5436: IO::File 5437: Apache::File 5438: Symbol 5439: POSIX 5440: Crypt::IDEA 5441: LWP::UserAgent() 5442: GDBM_File 5443: Authen::Krb4 5444: Authen::Krb5 5445: 5446: =head1 COREQUISITES 5447: 5448: =head1 OSNAMES 5449: 5450: linux 5451: 5452: =head1 SCRIPT CATEGORIES 5453: 5454: Server/Process 5455: 5456: =cut