loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.393: download - view: text, annotated - select for diffs
Mon Jan 7 02:21:35 2008 UTC (16 years, 3 months ago) by raeburn
Branches: MAIN
CVS tags: version_2_6_2, version_2_6_1, version_2_6_0, HEAD

Bug 5561. Double linefeed caused request/response process via lonc/lond to get out of sync.

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