loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.365: download - view: text, annotated - select for diffs
Wed Mar 28 22:14:33 2007 UTC (17 years, 7 months ago) by albertel
Branches: MAIN
CVS tags: HEAD

- use lonnet, eliminate copies of ruotines taht are in lonnet

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