loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.384: download - view: text, annotated - select for diffs
Sat Oct 6 04:32:23 2007 UTC (16 years, 6 months ago) by raeburn
Branches: MAIN
CVS tags: HEAD

Bug 5191.  Decouple storage of last access time for a course in nohist_courseids.db from storage of course information.
- Retain backwards compatibility with legacy lonnet::courseiddump()

Other general change: uniform use of 'inst_code' as key in frozen hash instead of 'instcode'.

lond
&put_course_id_handler()
- last access stored in escaped lasttime:courseid key = value hash item
  if legacy lonnet::courseiddump() updates courseinfo.
&put_course_id_hash_handler()
- additional argument - $mode ('timeonly', 'notime' or 'all')
  - determines whether last access, or courseinfo (description,inst_code,owner,type) or both are stored
&dump_course_id_handler()
- documentation updated
- style (replacing unless)
- change location of unescaping when checking filters so double escaping no longer needed for courseinfo stored in frozen hash
- return courseinfo in hash form, if requested as hash, when record has yet to be converted to a frozen hash
&validate_class_access_handler()
- eliminate extra unescaping of $ownerlist

lonnet.pm
&flushcourselogs() includes 'timeonly' argument in call to courseidput().
&courseidput() - if in 'timeonly' mode only courseids are sent to lond in courseidputhash call.
&createcourse()
- courseinfo values in hash no longer escaped (freeze_hash handles this)
- call to flushcourselogs() replaced by call to courseidput()

lonmodifycourse.pm
- courseinfo values in hash no longer escaped
- call to courseidput() includes 'notime' as fourth arg.

coursecatalog.pm
- remove unneeded code, since entry for each course in %courses hash will now be a hash ref.

courseclassifier.pm
- remove unneeded code, since entry for each course in %courses hash will now be a hash ref.

lonpickcourse.pm
- Entry for each course in %courses hash should be a hash ref, when constructing for onlyown courses case.
- instcode to inst_code
- no need to unescape courseinfo value (thaw_hash in lonnet::courseiddump does it)

lonparmset.pm
- call to flushcourselogs() replaced by call to courseidput() after updating course description.
- appenv user's session with new course description.

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