loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.270: download - view: text, annotated - select for diffs
Tue Dec 28 15:09:38 2004 UTC (19 years, 10 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

Mark's krb5 typo fix.

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