loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.523: download - view: text, annotated - select for diffs
Mon Jul 25 19:49:45 2016 UTC (7 years, 9 months ago) by raeburn
Branches: MAIN
CVS tags: HEAD

- Use Server Name Indication (SNI) and SSL when replicating content from
  /raw/.
- Domain status screen has link to show status of LON-CAPA SSL certificates.
- "SSL" domain config for (a) "internal" LON-CAPA SSL connection to servers/VMs
  in other domain, (b) Replication of domain's resources to other domains.
- Replication can use name-based virtual hosts with SSL, with verification of
  client certificate (cert: /home/httpd/lonCerts/lonhostnamecert.pem, signed
  by LON-CAPA CA, with Common Name of internal-<server hostname>, same IP address
  as server hostname).

1: #!/usr/bin/perl 2: # The LearningOnline Network 3: # lond "LON Daemon" Server (port "LOND" 5663) 4: # 5: # $Id: lond,v 1.523 2016/07/25 19:49:45 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: 19: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20: # GNU General Public License for more details. 21: # 22: # You should have received a copy of the GNU General Public License 23: # along with LON-CAPA; if not, write to the Free Software 24: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 25: # 26: # /home/httpd/html/adm/gpl.txt 27: # 28: 29: 30: # http://www.lon-capa.org/ 31: # 32: 33: use strict; 34: use lib '/home/httpd/lib/perl/'; 35: use LONCAPA; 36: use LONCAPA::Configuration; 37: use LONCAPA::Lond; 38: 39: use IO::Socket; 40: use IO::File; 41: #use Apache::File; 42: use POSIX; 43: use Crypt::IDEA; 44: use HTTP::Request; 45: use Digest::MD5 qw(md5_hex); 46: use GDBM_File; 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: use Mail::Send; 58: use Crypt::Eksblowfish::Bcrypt; 59: use Digest::SHA; 60: use Encode; 61: use LONCAPA::LWPReq; 62: 63: my $DEBUG = 0; # Non zero to enable debug log entries. 64: 65: my $status=''; 66: my $lastlog=''; 67: 68: my $VERSION='$Revision: 1.523 $'; #' stupid emacs 69: my $remoteVERSION; 70: my $currenthostid="default"; 71: my $currentdomainid; 72: 73: my $client; 74: my $clientip; # IP address of client. 75: my $clientname; # LonCAPA name of client. 76: my $clientversion; # LonCAPA version running on client. 77: my $clienthomedom; # LonCAPA domain of homeID for client. 78: # primary library server. 79: 80: my $server; 81: 82: my $keymode; 83: 84: my $cipher; # Cipher key negotiated with client 85: my $tmpsnum = 0; # Id of tmpputs. 86: 87: # 88: # Connection type is: 89: # client - All client actions are allowed 90: # manager - only management functions allowed. 91: # both - Both management and client actions are allowed 92: # 93: 94: my $ConnectionType; 95: 96: my %managers; # Ip -> manager names 97: 98: my %perlvar; # Will have the apache conf defined perl vars. 99: 100: my $dist; 101: 102: # 103: # The hash below is used for command dispatching, and is therefore keyed on the request keyword. 104: # Each element of the hash contains a reference to an array that contains: 105: # A reference to a sub that executes the request corresponding to the keyword. 106: # A flag that is true if the request must be encoded to be acceptable. 107: # A mask with bits as follows: 108: # CLIENT_OK - Set when the function is allowed by ordinary clients 109: # MANAGER_OK - Set when the function is allowed to manager clients. 110: # 111: my $CLIENT_OK = 1; 112: my $MANAGER_OK = 2; 113: my %Dispatcher; 114: 115: 116: # 117: # The array below are password error strings." 118: # 119: my $lastpwderror = 13; # Largest error number from lcpasswd. 120: my @passwderrors = ("ok", 121: "pwchange_failure - lcpasswd must be run as user 'www'", 122: "pwchange_failure - lcpasswd got incorrect number of arguments", 123: "pwchange_failure - lcpasswd did not get the right nubmer of input text lines", 124: "pwchange_failure - lcpasswd too many simultaneous pwd changes in progress", 125: "pwchange_failure - lcpasswd User does not exist.", 126: "pwchange_failure - lcpasswd Incorrect current passwd", 127: "pwchange_failure - lcpasswd Unable to su to root.", 128: "pwchange_failure - lcpasswd Cannot set new passwd.", 129: "pwchange_failure - lcpasswd Username has invalid characters", 130: "pwchange_failure - lcpasswd Invalid characters in password", 131: "pwchange_failure - lcpasswd User already exists", 132: "pwchange_failure - lcpasswd Something went wrong with user addition.", 133: "pwchange_failure - lcpasswd Password mismatch", 134: "pwchange_failure - lcpasswd Error filename is invalid"); 135: 136: 137: # This array are the errors from lcinstallfile: 138: 139: my @installerrors = ("ok", 140: "Initial user id of client not that of www", 141: "Usage error, not enough command line arguments", 142: "Source filename does not exist", 143: "Destination filename does not exist", 144: "Some file operation failed", 145: "Invalid table filename." 146: ); 147: 148: # 149: # Statistics that are maintained and dislayed in the status line. 150: # 151: my $Transactions = 0; # Number of attempted transactions. 152: my $Failures = 0; # Number of transcations failed. 153: 154: # ResetStatistics: 155: # Resets the statistics counters: 156: # 157: sub ResetStatistics { 158: $Transactions = 0; 159: $Failures = 0; 160: } 161: 162: #------------------------------------------------------------------------ 163: # 164: # LocalConnection 165: # Completes the formation of a locally authenticated connection. 166: # This function will ensure that the 'remote' client is really the 167: # local host. If not, the connection is closed, and the function fails. 168: # If so, initcmd is parsed for the name of a file containing the 169: # IDEA session key. The fie is opened, read, deleted and the session 170: # key returned to the caller. 171: # 172: # Parameters: 173: # $Socket - Socket open on client. 174: # $initcmd - The full text of the init command. 175: # 176: # Returns: 177: # IDEA session key on success. 178: # undef on failure. 179: # 180: sub LocalConnection { 181: my ($Socket, $initcmd) = @_; 182: Debug("Attempting local connection: $initcmd client: $clientip"); 183: if($clientip ne "127.0.0.1") { 184: &logthis(' LocalConnection rejecting non local: ' 185: ."$clientip ne 127.0.0.1 "); 186: close $Socket; 187: return undef; 188: } else { 189: chomp($initcmd); # Get rid of \n in filename. 190: my ($init, $type, $name) = split(/:/, $initcmd); 191: Debug(" Init command: $init $type $name "); 192: 193: # Require that $init = init, and $type = local: Otherwise 194: # the caller is insane: 195: 196: if(($init ne "init") && ($type ne "local")) { 197: &logthis(' LocalConnection: caller is insane! ' 198: ."init = $init, and type = $type "); 199: close($Socket);; 200: return undef; 201: 202: } 203: # Now get the key filename: 204: 205: my $IDEAKey = lonlocal::ReadKeyFile($name); 206: return $IDEAKey; 207: } 208: } 209: #------------------------------------------------------------------------------ 210: # 211: # SSLConnection 212: # Completes the formation of an ssh authenticated connection. The 213: # socket is promoted to an ssl socket. If this promotion and the associated 214: # certificate exchange are successful, the IDEA key is generated and sent 215: # to the remote peer via the SSL tunnel. The IDEA key is also returned to 216: # the caller after the SSL tunnel is torn down. 217: # 218: # Parameters: 219: # Name Type Purpose 220: # $Socket IO::Socket::INET Plaintext socket. 221: # 222: # Returns: 223: # IDEA key on success. 224: # undef on failure. 225: # 226: sub SSLConnection { 227: my $Socket = shift; 228: 229: Debug("SSLConnection: "); 230: my $KeyFile = lonssl::KeyFile(); 231: if(!$KeyFile) { 232: my $err = lonssl::LastError(); 233: &logthis(" CRITICAL" 234: ."Can't get key file $err "); 235: return undef; 236: } 237: my ($CACertificate, 238: $Certificate) = lonssl::CertificateFile(); 239: 240: 241: # If any of the key, certificate or certificate authority 242: # certificate filenames are not defined, this can't work. 243: 244: if((!$Certificate) || (!$CACertificate)) { 245: my $err = lonssl::LastError(); 246: &logthis(" CRITICAL" 247: ."Can't get certificates: $err "); 248: 249: return undef; 250: } 251: Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate"); 252: 253: # Indicate to our peer that we can procede with 254: # a transition to ssl authentication: 255: 256: print $Socket "ok:ssl\n"; 257: 258: Debug("Approving promotion -> ssl"); 259: # And do so: 260: 261: my $SSLSocket = lonssl::PromoteServerSocket($Socket, 262: $CACertificate, 263: $Certificate, 264: $KeyFile); 265: if(! ($SSLSocket) ) { # SSL socket promotion failed. 266: my $err = lonssl::LastError(); 267: &logthis(" CRITICAL " 268: ."SSL Socket promotion failed: $err "); 269: return undef; 270: } 271: Debug("SSL Promotion successful"); 272: 273: # 274: # The only thing we'll use the socket for is to send the IDEA key 275: # to the peer: 276: 277: my $Key = lonlocal::CreateCipherKey(); 278: print $SSLSocket "$Key\n"; 279: 280: lonssl::Close($SSLSocket); 281: 282: Debug("Key exchange complete: $Key"); 283: 284: return $Key; 285: } 286: # 287: # InsecureConnection: 288: # If insecure connections are allowd, 289: # exchange a challenge with the client to 'validate' the 290: # client (not really, but that's the protocol): 291: # We produce a challenge string that's sent to the client. 292: # The client must then echo the challenge verbatim to us. 293: # 294: # Parameter: 295: # Socket - Socket open on the client. 296: # Returns: 297: # 1 - success. 298: # 0 - failure (e.g.mismatch or insecure not allowed). 299: # 300: sub InsecureConnection { 301: my $Socket = shift; 302: 303: # Don't even start if insecure connections are not allowed. 304: 305: if(! $perlvar{londAllowInsecure}) { # Insecure connections not allowed. 306: return 0; 307: } 308: 309: # Fabricate a challenge string and send it.. 310: 311: my $challenge = "$$".time; # pid + time. 312: print $Socket "$challenge\n"; 313: &status("Waiting for challenge reply"); 314: 315: my $answer = <$Socket>; 316: $answer =~s/\W//g; 317: if($challenge eq $answer) { 318: return 1; 319: } else { 320: logthis("WARNING client did not respond to challenge"); 321: &status("No challenge reqply"); 322: return 0; 323: } 324: 325: 326: } 327: # 328: # Safely execute a command (as long as it's not a shel command and doesn 329: # not require/rely on shell escapes. The function operates by doing a 330: # a pipe based fork and capturing stdout and stderr from the pipe. 331: # 332: # Formal Parameters: 333: # $line - A line of text to be executed as a command. 334: # Returns: 335: # The output from that command. If the output is multiline the caller 336: # must know how to split up the output. 337: # 338: # 339: sub execute_command { 340: my ($line) = @_; 341: my @words = split(/\s/, $line); # Bust the command up into words. 342: my $output = ""; 343: 344: my $pid = open(CHILD, "-|"); 345: 346: if($pid) { # Parent process 347: Debug("In parent process for execute_command"); 348: my @data = <CHILD>; # Read the child's outupt... 349: close CHILD; 350: foreach my $output_line (@data) { 351: Debug("Adding $output_line"); 352: $output .= $output_line; # Presumably has a \n on it. 353: } 354: 355: } else { # Child process 356: close (STDERR); 357: open (STDERR, ">&STDOUT");# Combine stderr, and stdout... 358: exec(@words); # won't return. 359: } 360: return $output; 361: } 362: 363: 364: # GetCertificate: Given a transaction that requires a certificate, 365: # this function will extract the certificate from the transaction 366: # request. Note that at this point, the only concept of a certificate 367: # is the hostname to which we are connected. 368: # 369: # Parameter: 370: # request - The request sent by our client (this parameterization may 371: # need to change when we really use a certificate granting 372: # authority. 373: # 374: sub GetCertificate { 375: my $request = shift; 376: 377: return $clientip; 378: } 379: 380: # 381: # Return true if client is a manager. 382: # 383: sub isManager { 384: return (($ConnectionType eq "manager") || ($ConnectionType eq "both")); 385: } 386: # 387: # Return tru if client can do client functions 388: # 389: sub isClient { 390: return (($ConnectionType eq "client") || ($ConnectionType eq "both")); 391: } 392: 393: 394: # 395: # ReadManagerTable: Reads in the current manager table. For now this is 396: # done on each manager authentication because: 397: # - These authentications are not frequent 398: # - This allows dynamic changes to the manager table 399: # without the need to signal to the lond. 400: # 401: sub ReadManagerTable { 402: 403: &Debug("Reading manager table"); 404: # Clean out the old table first.. 405: 406: foreach my $key (keys %managers) { 407: delete $managers{$key}; 408: } 409: 410: my $tablename = $perlvar{'lonTabDir'}."/managers.tab"; 411: if (!open (MANAGERS, $tablename)) { 412: my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'}); 413: if (&Apache::lonnet::is_LC_dns($hostname)) { 414: &logthis('No manager table. Nobody can manage!!'); 415: } 416: return; 417: } 418: while(my $host = <MANAGERS>) { 419: chomp($host); 420: if ($host =~ "^#") { # Comment line. 421: next; 422: } 423: if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member 424: # The entry is of the form: 425: # cluname:hostname 426: # cluname - A 'cluster hostname' is needed in order to negotiate 427: # the host key. 428: # hostname- The dns name of the host. 429: # 430: my($cluname, $dnsname) = split(/:/, $host); 431: 432: my $ip = gethostbyname($dnsname); 433: if(defined($ip)) { # bad names don't deserve entry. 434: my $hostip = inet_ntoa($ip); 435: $managers{$hostip} = $cluname; 436: logthis(' registering manager '. 437: "$dnsname as $cluname with $hostip \n"); 438: } 439: } else { 440: logthis(' existing host'." $host\n"); 441: $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if cluster memeber 442: } 443: } 444: } 445: 446: # 447: # ValidManager: Determines if a given certificate represents a valid manager. 448: # in this primitive implementation, the 'certificate' is 449: # just the connecting loncapa client name. This is checked 450: # against a valid client list in the configuration. 451: # 452: # 453: sub ValidManager { 454: my $certificate = shift; 455: 456: return isManager; 457: } 458: # 459: # CopyFile: Called as part of the process of installing a 460: # new configuration file. This function copies an existing 461: # file to a backup file. 462: # Parameters: 463: # oldfile - Name of the file to backup. 464: # newfile - Name of the backup file. 465: # Return: 466: # 0 - Failure (errno has failure reason). 467: # 1 - Success. 468: # 469: sub CopyFile { 470: 471: my ($oldfile, $newfile) = @_; 472: 473: if (! copy($oldfile,$newfile)) { 474: return 0; 475: } 476: chmod(0660, $newfile); 477: return 1; 478: } 479: # 480: # Host files are passed out with externally visible host IPs. 481: # If, for example, we are behind a fire-wall or NAT host, our 482: # internally visible IP may be different than the externally 483: # visible IP. Therefore, we always adjust the contents of the 484: # host file so that the entry for ME is the IP that we believe 485: # we have. At present, this is defined as the entry that 486: # DNS has for us. If by some chance we are not able to get a 487: # DNS translation for us, then we assume that the host.tab file 488: # is correct. 489: # BUGBUGBUG - in the future, we really should see if we can 490: # easily query the interface(s) instead. 491: # Parameter(s): 492: # contents - The contents of the host.tab to check. 493: # Returns: 494: # newcontents - The adjusted contents. 495: # 496: # 497: sub AdjustHostContents { 498: my $contents = shift; 499: my $adjusted; 500: my $me = $perlvar{'lonHostID'}; 501: 502: foreach my $line (split(/\n/,$contents)) { 503: if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) || 504: ($line =~ /^\s*\^/))) { 505: chomp($line); 506: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); 507: if ($id eq $me) { 508: my $ip = gethostbyname($name); 509: my $ipnew = inet_ntoa($ip); 510: $ip = $ipnew; 511: # Reconstruct the host line and append to adjusted: 512: 513: my $newline = "$id:$domain:$role:$name:$ip"; 514: if($maxcon ne "") { # Not all hosts have loncnew tuning params 515: $newline .= ":$maxcon:$idleto:$mincon"; 516: } 517: $adjusted .= $newline."\n"; 518: 519: } else { # Not me, pass unmodified. 520: $adjusted .= $line."\n"; 521: } 522: } else { # Blank or comment never re-written. 523: $adjusted .= $line."\n"; # Pass blanks and comments as is. 524: } 525: } 526: return $adjusted; 527: } 528: # 529: # InstallFile: Called to install an administrative file: 530: # - The file is created int a temp directory called <name>.tmp 531: # - lcinstall file is called to install the file. 532: # since the web app has no direct write access to the table directory 533: # 534: # Parameters: 535: # Name of the file 536: # File Contents. 537: # Return: 538: # nonzero - success. 539: # 0 - failure and $! has an errno. 540: # Assumptions: 541: # File installtion is a relatively infrequent 542: # 543: sub InstallFile { 544: 545: my ($Filename, $Contents) = @_; 546: # my $TempFile = $Filename.".tmp"; 547: my $exedir = $perlvar{'lonDaemons'}; 548: my $tmpdir = $exedir.'/tmp/'; 549: my $TempFile = $tmpdir."TempTableFile.tmp"; 550: 551: # Open the file for write: 552: 553: my $fh = IO::File->new("> $TempFile"); # Write to temp. 554: if(!(defined $fh)) { 555: &logthis(' Unable to create '.$TempFile.""); 556: return 0; 557: } 558: # write the contents of the file: 559: 560: print $fh ($Contents); 561: $fh->close; # In case we ever have a filesystem w. locking 562: 563: chmod(0664, $TempFile); # Everyone can write it. 564: 565: # Use lcinstall file to put the file in the table directory... 566: 567: &Debug("Opening pipe to $exedir/lcinstallfile $TempFile $Filename"); 568: my $pf = IO::File->new("| $exedir/lcinstallfile $TempFile $Filename > $exedir/logs/lcinstallfile.log"); 569: close $pf; 570: my $err = $?; 571: &Debug("Status is $err"); 572: if ($err != 0) { 573: my $msg = $err; 574: if ($err < @installerrors) { 575: $msg = $installerrors[$err]; 576: } 577: &logthis("Install failed for table file $Filename : $msg"); 578: return 0; 579: } 580: 581: # Remove the temp file: 582: 583: unlink($TempFile); 584: 585: return 1; 586: } 587: 588: 589: # 590: # ConfigFileFromSelector: converts a configuration file selector 591: # into a configuration file pathname. 592: # Supports the following file selectors: 593: # hosts, domain, dns_hosts, dns_domain 594: # 595: # 596: # Parameters: 597: # selector - Configuration file selector. 598: # Returns: 599: # Full path to the file or undef if the selector is invalid. 600: # 601: sub ConfigFileFromSelector { 602: my $selector = shift; 603: my $tablefile; 604: 605: my $tabledir = $perlvar{'lonTabDir'}.'/'; 606: if (($selector eq "hosts") || ($selector eq "domain") || 607: ($selector eq "dns_hosts") || ($selector eq "dns_domain")) { 608: $tablefile = $tabledir.$selector.'.tab'; 609: } 610: return $tablefile; 611: } 612: # 613: # PushFile: Called to do an administrative push of a file. 614: # - Ensure the file being pushed is one we support. 615: # - Backup the old file to <filename.saved> 616: # - Separate the contents of the new file out from the 617: # rest of the request. 618: # - Write the new file. 619: # Parameter: 620: # Request - The entire user request. This consists of a : separated 621: # string pushfile:tablename:contents. 622: # NOTE: The contents may have :'s in it as well making things a bit 623: # more interesting... but not much. 624: # Returns: 625: # String to send to client ("ok" or "refused" if bad file). 626: # 627: sub PushFile { 628: my $request = shift; 629: my ($command, $filename, $contents) = split(":", $request, 3); 630: &Debug("PushFile"); 631: 632: # At this point in time, pushes for only the following tables are 633: # supported: 634: # hosts.tab ($filename eq host). 635: # domain.tab ($filename eq domain). 636: # dns_hosts.tab ($filename eq dns_host). 637: # dns_domain.tab ($filename eq dns_domain). 638: # Construct the destination filename or reject the request. 639: # 640: # lonManage is supposed to ensure this, however this session could be 641: # part of some elaborate spoof that managed somehow to authenticate. 642: # 643: 644: 645: my $tablefile = ConfigFileFromSelector($filename); 646: if(! (defined $tablefile)) { 647: return "refused"; 648: } 649: 650: # If the file being pushed is the host file, we adjust the entry for ourself so that the 651: # IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible 652: # to conceive of conditions where we don't have a DNS entry locally. This is possible in a 653: # network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now) 654: # that possibilty. 655: 656: if($filename eq "host") { 657: $contents = AdjustHostContents($contents); 658: } elsif ($filename eq 'dns_host' || $filename eq 'dns_domain') { 659: if ($contents eq '') { 660: &logthis(' Pushfile: unable to install ' 661: .$tablefile." - no data received from push. "); 662: return 'error: push had no data'; 663: } 664: if (&Apache::lonnet::get_host_ip($clientname)) { 665: my $clienthost = &Apache::lonnet::hostname($clientname); 666: if ($managers{$clientip} eq $clientname) { 667: my $clientprotocol = $Apache::lonnet::protocol{$clientname}; 668: $clientprotocol = 'http' if ($clientprotocol ne 'https'); 669: my $url = '/adm/'.$filename; 670: $url =~ s{_}{/}; 671: my $request=new HTTP::Request('GET',"$clientprotocol://$clienthost$url"); 672: my $response = LONCAPA::LWPReq::makerequest($clientname,$request,'',\%perlvar,60,0); 673: if ($response->is_error()) { 674: &logthis(' Pushfile: unable to install ' 675: .$tablefile." - error attempting to pull data. "); 676: return 'error: pull failed'; 677: } else { 678: my $result = $response->content; 679: chomp($result); 680: unless ($result eq $contents) { 681: &logthis(' Pushfile: unable to install ' 682: .$tablefile." - pushed data and pulled data differ. "); 683: my $pushleng = length($contents); 684: my $pullleng = length($result); 685: if ($pushleng != $pullleng) { 686: return "error: $pushleng vs $pullleng bytes"; 687: } else { 688: return "error: mismatch push and pull"; 689: } 690: } 691: } 692: } 693: } 694: } 695: 696: # Install the new file: 697: 698: &logthis("Installing new $tablefile contents:\n$contents"); 699: if(!InstallFile($tablefile, $contents)) { 700: &logthis(' Pushfile: unable to install ' 701: .$tablefile." $! "); 702: return "error:$!"; 703: } else { 704: &logthis(' Installed new '.$tablefile 705: ." - transaction by: $clientname ($clientip)"); 706: my $adminmail = $perlvar{'lonAdmEMail'}; 707: my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); 708: if ($admindom ne '') { 709: my %domconfig = 710: &Apache::lonnet::get_dom('configuration',['contacts'],$admindom); 711: if (ref($domconfig{'contacts'}) eq 'HASH') { 712: if ($domconfig{'contacts'}{'adminemail'} ne '') { 713: $adminmail = $domconfig{'contacts'}{'adminemail'}; 714: } 715: } 716: } 717: if ($adminmail =~ /^[^\@]+\@[^\@]+$/) { 718: my $msg = new Mail::Send; 719: $msg->to($adminmail); 720: $msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'}); 721: $msg->add('Content-type','text/plain; charset=UTF-8'); 722: if (my $fh = $msg->open()) { 723: print $fh 'Update to '.$tablefile.' from Cluster Manager '. 724: "$clientname ($clientip)\n"; 725: $fh->close; 726: } 727: } 728: } 729: 730: # Indicate success: 731: 732: return "ok"; 733: 734: } 735: 736: # 737: # Called to re-init either lonc or lond. 738: # 739: # Parameters: 740: # request - The full request by the client. This is of the form 741: # reinit:<process> 742: # where <process> is allowed to be either of 743: # lonc or lond 744: # 745: # Returns: 746: # The string to be sent back to the client either: 747: # ok - Everything worked just fine. 748: # error:why - There was a failure and why describes the reason. 749: # 750: # 751: sub ReinitProcess { 752: my $request = shift; 753: 754: 755: # separate the request (reinit) from the process identifier and 756: # validate it producing the name of the .pid file for the process. 757: # 758: # 759: my ($junk, $process) = split(":", $request); 760: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/'; 761: if($process eq 'lonc') { 762: $processpidfile = $processpidfile."lonc.pid"; 763: if (!open(PIDFILE, "< $processpidfile")) { 764: return "error:Open failed for $processpidfile"; 765: } 766: my $loncpid = <PIDFILE>; 767: close(PIDFILE); 768: logthis(' Reinitializing lonc pid='.$loncpid 769: .""); 770: kill("USR2", $loncpid); 771: } elsif ($process eq 'lond') { 772: logthis(' Reinitializing self (lond) '); 773: &UpdateHosts; # Lond is us!! 774: } else { 775: &logthis('"); 777: return "error:Invalid process identifier $process"; 778: } 779: return 'ok'; 780: } 781: # Validate a line in a configuration file edit script: 782: # Validation includes: 783: # - Ensuring the command is valid. 784: # - Ensuring the command has sufficient parameters 785: # Parameters: 786: # scriptline - A line to validate (\n has been stripped for what it's worth). 787: # 788: # Return: 789: # 0 - Invalid scriptline. 790: # 1 - Valid scriptline 791: # NOTE: 792: # Only the command syntax is checked, not the executability of the 793: # command. 794: # 795: sub isValidEditCommand { 796: my $scriptline = shift; 797: 798: # Line elements are pipe separated: 799: 800: my ($command, $key, $newline) = split(/\|/, $scriptline); 801: &logthis(' isValideditCommand checking: '. 802: "Command = '$command', Key = '$key', Newline = '$newline' \n"); 803: 804: if ($command eq "delete") { 805: # 806: # key with no newline. 807: # 808: if( ($key eq "") || ($newline ne "")) { 809: return 0; # Must have key but no newline. 810: } else { 811: return 1; # Valid syntax. 812: } 813: } elsif ($command eq "replace") { 814: # 815: # key and newline: 816: # 817: if (($key eq "") || ($newline eq "")) { 818: return 0; 819: } else { 820: return 1; 821: } 822: } elsif ($command eq "append") { 823: if (($key ne "") && ($newline eq "")) { 824: return 1; 825: } else { 826: return 0; 827: } 828: } else { 829: return 0; # Invalid command. 830: } 831: return 0; # Should not get here!!! 832: } 833: # 834: # ApplyEdit - Applies an edit command to a line in a configuration 835: # file. It is the caller's responsiblity to validate the 836: # edit line. 837: # Parameters: 838: # $directive - A single edit directive to apply. 839: # Edit directives are of the form: 840: # append|newline - Appends a new line to the file. 841: # replace|key|newline - Replaces the line with key value 'key' 842: # delete|key - Deletes the line with key value 'key'. 843: # $editor - A config file editor object that contains the 844: # file being edited. 845: # 846: sub ApplyEdit { 847: 848: my ($directive, $editor) = @_; 849: 850: # Break the directive down into its command and its parameters 851: # (at most two at this point. The meaning of the parameters, if in fact 852: # they exist depends on the command). 853: 854: my ($command, $p1, $p2) = split(/\|/, $directive); 855: 856: if($command eq "append") { 857: $editor->Append($p1); # p1 - key p2 null. 858: } elsif ($command eq "replace") { 859: $editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline. 860: } elsif ($command eq "delete") { 861: $editor->DeleteLine($p1); # p1 - key p2 null. 862: } else { # Should not get here!!! 863: die "Invalid command given to ApplyEdit $command" 864: } 865: } 866: # 867: # AdjustOurHost: 868: # Adjusts a host file stored in a configuration file editor object 869: # for the true IP address of this host. This is necessary for hosts 870: # that live behind a firewall. 871: # Those hosts have a publicly distributed IP of the firewall, but 872: # internally must use their actual IP. We assume that a given 873: # host only has a single IP interface for now. 874: # Formal Parameters: 875: # editor - The configuration file editor to adjust. This 876: # editor is assumed to contain a hosts.tab file. 877: # Strategy: 878: # - Figure out our hostname. 879: # - Lookup the entry for this host. 880: # - Modify the line to contain our IP 881: # - Do a replace for this host. 882: sub AdjustOurHost { 883: my $editor = shift; 884: 885: # figure out who I am. 886: 887: my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname. 888: 889: # Get my host file entry. 890: 891: my $ConfigLine = $editor->Find($myHostName); 892: if(! (defined $ConfigLine)) { 893: die "AdjustOurHost - no entry for me in hosts file $myHostName"; 894: } 895: # figure out my IP: 896: # Use the config line to get my hostname. 897: # Use gethostbyname to translate that into an IP address. 898: # 899: my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine); 900: # 901: # Reassemble the config line from the elements in the list. 902: # Note that if the loncnew items were not present before, they will 903: # be now even if they would be empty 904: # 905: my $newConfigLine = $id; 906: foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) { 907: $newConfigLine .= ":".$item; 908: } 909: # Replace the line: 910: 911: $editor->ReplaceLine($id, $newConfigLine); 912: 913: } 914: # 915: # ReplaceConfigFile: 916: # Replaces a configuration file with the contents of a 917: # configuration file editor object. 918: # This is done by: 919: # - Copying the target file to <filename>.old 920: # - Writing the new file to <filename>.tmp 921: # - Moving <filename.tmp> -> <filename> 922: # This laborious process ensures that the system is never without 923: # a configuration file that's at least valid (even if the contents 924: # may be dated). 925: # Parameters: 926: # filename - Name of the file to modify... this is a full path. 927: # editor - Editor containing the file. 928: # 929: sub ReplaceConfigFile { 930: 931: my ($filename, $editor) = @_; 932: 933: CopyFile ($filename, $filename.".old"); 934: 935: my $contents = $editor->Get(); # Get the contents of the file. 936: 937: InstallFile($filename, $contents); 938: } 939: # 940: # 941: # Called to edit a configuration table file 942: # Parameters: 943: # request - The entire command/request sent by lonc or lonManage 944: # Return: 945: # The reply to send to the client. 946: # 947: sub EditFile { 948: my $request = shift; 949: 950: # Split the command into it's pieces: edit:filetype:script 951: 952: my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script 953: 954: # Check the pre-coditions for success: 955: 956: if($cmd != "edit") { # Something is amiss afoot alack. 957: return "error:edit request detected, but request != 'edit'\n"; 958: } 959: if( ($filetype ne "hosts") && 960: ($filetype ne "domain")) { 961: return "error:edit requested with invalid file specifier: $filetype \n"; 962: } 963: 964: # Split the edit script and check it's validity. 965: 966: my @scriptlines = split(/\n/, $script); # one line per element. 967: my $linecount = scalar(@scriptlines); 968: for(my $i = 0; $i < $linecount; $i++) { 969: chomp($scriptlines[$i]); 970: if(!isValidEditCommand($scriptlines[$i])) { 971: return "error:edit with bad script line: '$scriptlines[$i]' \n"; 972: } 973: } 974: 975: # Execute the edit operation. 976: # - Create a config file editor for the appropriate file and 977: # - execute each command in the script: 978: # 979: my $configfile = ConfigFileFromSelector($filetype); 980: if (!(defined $configfile)) { 981: return "refused\n"; 982: } 983: my $editor = ConfigFileEdit->new($configfile); 984: 985: for (my $i = 0; $i < $linecount; $i++) { 986: ApplyEdit($scriptlines[$i], $editor); 987: } 988: # If the file is the host file, ensure that our host is 989: # adjusted to have our ip: 990: # 991: if($filetype eq "host") { 992: AdjustOurHost($editor); 993: } 994: # Finally replace the current file with our file. 995: # 996: ReplaceConfigFile($configfile, $editor); 997: 998: return "ok\n"; 999: } 1000: 1001: # read_profile 1002: # 1003: # Returns a set of specific entries from a user's profile file. 1004: # this is a utility function that is used by both get_profile_entry and 1005: # get_profile_entry_encrypted. 1006: # 1007: # Parameters: 1008: # udom - Domain in which the user exists. 1009: # uname - User's account name (loncapa account) 1010: # namespace - The profile namespace to open. 1011: # what - A set of & separated queries. 1012: # Returns: 1013: # If all ok: - The string that needs to be shipped back to the user. 1014: # If failure - A string that starts with error: followed by the failure 1015: # reason.. note that this probabyl gets shipped back to the 1016: # user as well. 1017: # 1018: sub read_profile { 1019: my ($udom, $uname, $namespace, $what) = @_; 1020: 1021: my $hashref = &tie_user_hash($udom, $uname, $namespace, 1022: &GDBM_READER()); 1023: if ($hashref) { 1024: my @queries=split(/\&/,$what); 1025: if ($namespace eq 'roles') { 1026: @queries = map { &unescape($_); } @queries; 1027: } 1028: my $qresult=''; 1029: 1030: for (my $i=0;$i<=$#queries;$i++) { 1031: $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. 1032: } 1033: $qresult=~s/\&$//; # Remove trailing & from last lookup. 1034: if (&untie_user_hash($hashref)) { 1035: return $qresult; 1036: } else { 1037: return "error: ".($!+0)." untie (GDBM) Failed"; 1038: } 1039: } else { 1040: if ($!+0 == 2) { 1041: return "error:No such file or GDBM reported bad block error"; 1042: } else { 1043: return "error: ".($!+0)." tie (GDBM) Failed"; 1044: } 1045: } 1046: 1047: } 1048: #--------------------- Request Handlers -------------------------------------------- 1049: # 1050: # By convention each request handler registers itself prior to the sub 1051: # declaration: 1052: # 1053: 1054: #++ 1055: # 1056: # Handles ping requests. 1057: # Parameters: 1058: # $cmd - the actual keyword that invoked us. 1059: # $tail - the tail of the request that invoked us. 1060: # $replyfd- File descriptor connected to the client 1061: # Implicit Inputs: 1062: # $currenthostid - Global variable that carries the name of the host we are 1063: # known as. 1064: # Returns: 1065: # 1 - Ok to continue processing. 1066: # 0 - Program should exit. 1067: # Side effects: 1068: # Reply information is sent to the client. 1069: sub ping_handler { 1070: my ($cmd, $tail, $client) = @_; 1071: Debug("$cmd $tail $client .. $currenthostid:"); 1072: 1073: Reply( $client,\$currenthostid,"$cmd:$tail"); 1074: 1075: return 1; 1076: } 1077: &register_handler("ping", \&ping_handler, 0, 1, 1); # Ping unencoded, client or manager. 1078: 1079: #++ 1080: # 1081: # Handles pong requests. Pong replies with our current host id, and 1082: # the results of a ping sent to us via our lonc. 1083: # 1084: # Parameters: 1085: # $cmd - the actual keyword that invoked us. 1086: # $tail - the tail of the request that invoked us. 1087: # $replyfd- File descriptor connected to the client 1088: # Implicit Inputs: 1089: # $currenthostid - Global variable that carries the name of the host we are 1090: # connected to. 1091: # Returns: 1092: # 1 - Ok to continue processing. 1093: # 0 - Program should exit. 1094: # Side effects: 1095: # Reply information is sent to the client. 1096: sub pong_handler { 1097: my ($cmd, $tail, $replyfd) = @_; 1098: 1099: my $reply=&Apache::lonnet::reply("ping",$clientname); 1100: &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 1101: return 1; 1102: } 1103: &register_handler("pong", \&pong_handler, 0, 1, 1); # Pong unencoded, client or manager 1104: 1105: #++ 1106: # Called to establish an encrypted session key with the remote client. 1107: # Note that with secure lond, in most cases this function is never 1108: # invoked. Instead, the secure session key is established either 1109: # via a local file that's locked down tight and only lives for a short 1110: # time, or via an ssl tunnel...and is generated from a bunch-o-random 1111: # bits from /dev/urandom, rather than the predictable pattern used by 1112: # by this sub. This sub is only used in the old-style insecure 1113: # key negotiation. 1114: # Parameters: 1115: # $cmd - the actual keyword that invoked us. 1116: # $tail - the tail of the request that invoked us. 1117: # $replyfd- File descriptor connected to the client 1118: # Implicit Inputs: 1119: # $currenthostid - Global variable that carries the name of the host 1120: # known as. 1121: # $clientname - Global variable that carries the name of the host we're connected to. 1122: # Returns: 1123: # 1 - Ok to continue processing. 1124: # 0 - Program should exit. 1125: # Implicit Outputs: 1126: # Reply information is sent to the client. 1127: # $cipher is set with a reference to a new IDEA encryption object. 1128: # 1129: sub establish_key_handler { 1130: my ($cmd, $tail, $replyfd) = @_; 1131: 1132: my $buildkey=time.$$.int(rand 100000); 1133: $buildkey=~tr/1-6/A-F/; 1134: $buildkey=int(rand 100000).$buildkey.int(rand 100000); 1135: my $key=$currenthostid.$clientname; 1136: $key=~tr/a-z/A-Z/; 1137: $key=~tr/G-P/0-9/; 1138: $key=~tr/Q-Z/0-9/; 1139: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey; 1140: $key=substr($key,0,32); 1141: my $cipherkey=pack("H32",$key); 1142: $cipher=new IDEA $cipherkey; 1143: &Reply($replyfd, \$buildkey, "$cmd:$tail"); 1144: 1145: return 1; 1146: 1147: } 1148: &register_handler("ekey", \&establish_key_handler, 0, 1,1); 1149: 1150: # Handler for the load command. Returns the current system load average 1151: # to the requestor. 1152: # 1153: # Parameters: 1154: # $cmd - the actual keyword that invoked us. 1155: # $tail - the tail of the request that invoked us. 1156: # $replyfd- File descriptor connected to the client 1157: # Implicit Inputs: 1158: # $currenthostid - Global variable that carries the name of the host 1159: # known as. 1160: # $clientname - Global variable that carries the name of the host we're connected to. 1161: # Returns: 1162: # 1 - Ok to continue processing. 1163: # 0 - Program should exit. 1164: # Side effects: 1165: # Reply information is sent to the client. 1166: sub load_handler { 1167: my ($cmd, $tail, $replyfd) = @_; 1168: 1169: 1170: 1171: # Get the load average from /proc/loadavg and calculate it as a percentage of 1172: # the allowed load limit as set by the perl global variable lonLoadLim 1173: 1174: my $loadavg; 1175: my $loadfile=IO::File->new('/proc/loadavg'); 1176: 1177: $loadavg=<$loadfile>; 1178: $loadavg =~ s/\s.*//g; # Extract the first field only. 1179: 1180: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; 1181: 1182: &Reply( $replyfd, \$loadpercent, "$cmd:$tail"); 1183: 1184: return 1; 1185: } 1186: &register_handler("load", \&load_handler, 0, 1, 0); 1187: 1188: # 1189: # Process the userload request. This sub returns to the client the current 1190: # user load average. It can be invoked either by clients or managers. 1191: # 1192: # Parameters: 1193: # $cmd - the actual keyword that invoked us. 1194: # $tail - the tail of the request that invoked us. 1195: # $replyfd- File descriptor connected to the client 1196: # Implicit Inputs: 1197: # $currenthostid - Global variable that carries the name of the host 1198: # known as. 1199: # $clientname - Global variable that carries the name of the host we're connected to. 1200: # Returns: 1201: # 1 - Ok to continue processing. 1202: # 0 - Program should exit 1203: # Implicit inputs: 1204: # whatever the userload() function requires. 1205: # Implicit outputs: 1206: # the reply is written to the client. 1207: # 1208: sub user_load_handler { 1209: my ($cmd, $tail, $replyfd) = @_; 1210: 1211: my $userloadpercent=&Apache::lonnet::userload(); 1212: &Reply($replyfd, \$userloadpercent, "$cmd:$tail"); 1213: 1214: return 1; 1215: } 1216: &register_handler("userload", \&user_load_handler, 0, 1, 0); 1217: 1218: # Process a request for the authorization type of a user: 1219: # (userauth). 1220: # 1221: # Parameters: 1222: # $cmd - the actual keyword that invoked us. 1223: # $tail - the tail of the request that invoked us. 1224: # $replyfd- File descriptor connected to the client 1225: # Returns: 1226: # 1 - Ok to continue processing. 1227: # 0 - Program should exit 1228: # Implicit outputs: 1229: # The user authorization type is written to the client. 1230: # 1231: sub user_authorization_type { 1232: my ($cmd, $tail, $replyfd) = @_; 1233: 1234: my $userinput = "$cmd:$tail"; 1235: 1236: # Pull the domain and username out of the command tail. 1237: # and call get_auth_type to determine the authentication type. 1238: 1239: my ($udom,$uname)=split(/:/,$tail); 1240: my $result = &get_auth_type($udom, $uname); 1241: if($result eq "nouser") { 1242: &Failure( $replyfd, "unknown_user\n", $userinput); 1243: } else { 1244: # 1245: # We only want to pass the second field from get_auth_type 1246: # for ^krb.. otherwise we'll be handing out the encrypted 1247: # password for internals e.g. 1248: # 1249: my ($type,$otherinfo) = split(/:/,$result); 1250: if($type =~ /^krb/) { 1251: $type = $result; 1252: } else { 1253: $type .= ':'; 1254: } 1255: &Reply( $replyfd, \$type, $userinput); 1256: } 1257: 1258: return 1; 1259: } 1260: &register_handler("currentauth", \&user_authorization_type, 1, 1, 0); 1261: 1262: # Process a request by a manager to push a hosts or domain table 1263: # to us. We pick apart the command and pass it on to the subs 1264: # that already exist to do this. 1265: # 1266: # Parameters: 1267: # $cmd - the actual keyword that invoked us. 1268: # $tail - the tail of the request that invoked us. 1269: # $client - File descriptor connected to the client 1270: # Returns: 1271: # 1 - Ok to continue processing. 1272: # 0 - Program should exit 1273: # Implicit Output: 1274: # a reply is written to the client. 1275: sub push_file_handler { 1276: my ($cmd, $tail, $client) = @_; 1277: &Debug("In push file handler"); 1278: my $userinput = "$cmd:$tail"; 1279: 1280: # At this time we only know that the IP of our partner is a valid manager 1281: # the code below is a hook to do further authentication (e.g. to resolve 1282: # spoofing). 1283: 1284: my $cert = &GetCertificate($userinput); 1285: if(&ValidManager($cert)) { 1286: &Debug("Valid manager: $client"); 1287: 1288: # Now presumably we have the bona fides of both the peer host and the 1289: # process making the request. 1290: 1291: my $reply = &PushFile($userinput); 1292: &Reply($client, \$reply, $userinput); 1293: 1294: } else { 1295: &logthis("push_file_handler $client is not valid"); 1296: &Failure( $client, "refused\n", $userinput); 1297: } 1298: return 1; 1299: } 1300: &register_handler("pushfile", \&push_file_handler, 1, 0, 1); 1301: 1302: # The du_handler routine should be considered obsolete and is retained 1303: # for communication with legacy servers. Please see the du2_handler. 1304: # 1305: # du - list the disk usage of a directory recursively. 1306: # 1307: # note: stolen code from the ls file handler 1308: # under construction by Rick Banghart 1309: # . 1310: # Parameters: 1311: # $cmd - The command that dispatched us (du). 1312: # $ududir - The directory path to list... I'm not sure what this 1313: # is relative as things like ls:. return e.g. 1314: # no_such_dir. 1315: # $client - Socket open on the client. 1316: # Returns: 1317: # 1 - indicating that the daemon should not disconnect. 1318: # Side Effects: 1319: # The reply is written to $client. 1320: # 1321: sub du_handler { 1322: my ($cmd, $ududir, $client) = @_; 1323: ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier. 1324: my $userinput = "$cmd:$ududir"; 1325: 1326: if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) { 1327: &Failure($client,"refused\n","$cmd:$ududir"); 1328: return 1; 1329: } 1330: # Since $ududir could have some nasties in it, 1331: # we will require that ududir is a valid 1332: # directory. Just in case someone tries to 1333: # slip us a line like .;(cd /home/httpd rm -rf*) 1334: # etc. 1335: # 1336: if (-d $ududir) { 1337: my $total_size=0; 1338: my $code=sub { 1339: if ($_=~/\.\d+\./) { return;} 1340: if ($_=~/\.meta$/) { return;} 1341: if (-d $_) { return;} 1342: $total_size+=(stat($_))[7]; 1343: }; 1344: chdir($ududir); 1345: find($code,$ududir); 1346: $total_size=int($total_size/1024); 1347: &Reply($client,\$total_size,"$cmd:$ududir"); 1348: } else { 1349: &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); 1350: } 1351: return 1; 1352: } 1353: &register_handler("du", \&du_handler, 0, 1, 0); 1354: 1355: # Please also see the du_handler, which is obsoleted by du2. 1356: # du2_handler differs from du_handler in that required path to directory 1357: # provided by &propath() is prepended in the handler instead of on the 1358: # client side. 1359: # 1360: # du2 - list the disk usage of a directory recursively. 1361: # 1362: # Parameters: 1363: # $cmd - The command that dispatched us (du). 1364: # $tail - The tail of the request that invoked us. 1365: # $tail is a : separated list of the following: 1366: # - $ududir - directory path to list (before prepending) 1367: # - $getpropath = 1 if &propath() should prepend 1368: # - $uname - username to use for &propath or user dir 1369: # - $udom - domain to use for &propath or user dir 1370: # All are escaped. 1371: # $client - Socket open on the client. 1372: # Returns: 1373: # 1 - indicating that the daemon should not disconnect. 1374: # Side Effects: 1375: # The reply is written to $client. 1376: # 1377: 1378: sub du2_handler { 1379: my ($cmd, $tail, $client) = @_; 1380: my ($ududir,$getpropath,$uname,$udom) = map { &unescape($_) } (split(/:/, $tail)); 1381: my $userinput = "$cmd:$tail"; 1382: if (($ududir=~/\.\./) || (($ududir!~m|^/home/httpd/|) && (!$getpropath))) { 1383: &Failure($client,"refused\n","$cmd:$tail"); 1384: return 1; 1385: } 1386: if ($getpropath) { 1387: if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) { 1388: $ududir = &propath($udom,$uname).'/'.$ududir; 1389: } else { 1390: &Failure($client,"refused\n","$cmd:$tail"); 1391: return 1; 1392: } 1393: } 1394: # Since $ududir could have some nasties in it, 1395: # we will require that ududir is a valid 1396: # directory. Just in case someone tries to 1397: # slip us a line like .;(cd /home/httpd rm -rf*) 1398: # etc. 1399: # 1400: if (-d $ududir) { 1401: my $total_size=0; 1402: my $code=sub { 1403: if ($_=~/\.\d+\./) { return;} 1404: if ($_=~/\.meta$/) { return;} 1405: if (-d $_) { return;} 1406: $total_size+=(stat($_))[7]; 1407: }; 1408: chdir($ududir); 1409: find($code,$ududir); 1410: $total_size=int($total_size/1024); 1411: &Reply($client,\$total_size,"$cmd:$ududir"); 1412: } else { 1413: &Failure($client, "bad_directory:$ududir\n","$cmd:$tail"); 1414: } 1415: return 1; 1416: } 1417: &register_handler("du2", \&du2_handler, 0, 1, 0); 1418: 1419: # 1420: # The ls_handler routine should be considered obsolete and is retained 1421: # for communication with legacy servers. Please see the ls3_handler. 1422: # 1423: # ls - list the contents of a directory. For each file in the 1424: # selected directory the filename followed by the full output of 1425: # the stat function is returned. The returned info for each 1426: # file are separated by ':'. The stat fields are separated by &'s. 1427: # Parameters: 1428: # $cmd - The command that dispatched us (ls). 1429: # $ulsdir - The directory path to list... I'm not sure what this 1430: # is relative as things like ls:. return e.g. 1431: # no_such_dir. 1432: # $client - Socket open on the client. 1433: # Returns: 1434: # 1 - indicating that the daemon should not disconnect. 1435: # Side Effects: 1436: # The reply is written to $client. 1437: # 1438: sub ls_handler { 1439: # obsoleted by ls2_handler 1440: my ($cmd, $ulsdir, $client) = @_; 1441: 1442: my $userinput = "$cmd:$ulsdir"; 1443: 1444: my $obs; 1445: my $rights; 1446: my $ulsout=''; 1447: my $ulsfn; 1448: if (-e $ulsdir) { 1449: if(-d $ulsdir) { 1450: if (opendir(LSDIR,$ulsdir)) { 1451: while ($ulsfn=readdir(LSDIR)) { 1452: undef($obs); 1453: undef($rights); 1454: my @ulsstats=stat($ulsdir.'/'.$ulsfn); 1455: #We do some obsolete checking here 1456: if(-e $ulsdir.'/'.$ulsfn.".meta") { 1457: open(FILE, $ulsdir.'/'.$ulsfn.".meta"); 1458: my @obsolete=<FILE>; 1459: foreach my $obsolete (@obsolete) { 1460: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 1461: if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; } 1462: } 1463: } 1464: $ulsout.=$ulsfn.'&'.join('&',@ulsstats); 1465: if($obs eq '1') { $ulsout.="&1"; } 1466: else { $ulsout.="&0"; } 1467: if($rights eq '1') { $ulsout.="&1:"; } 1468: else { $ulsout.="&0:"; } 1469: } 1470: closedir(LSDIR); 1471: } 1472: } else { 1473: my @ulsstats=stat($ulsdir); 1474: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; 1475: } 1476: } else { 1477: $ulsout='no_such_dir'; 1478: } 1479: if ($ulsout eq '') { $ulsout='empty'; } 1480: &Reply($client, \$ulsout, $userinput); # This supports debug logging. 1481: 1482: return 1; 1483: 1484: } 1485: &register_handler("ls", \&ls_handler, 0, 1, 0); 1486: 1487: # The ls2_handler routine should be considered obsolete and is retained 1488: # for communication with legacy servers. Please see the ls3_handler. 1489: # Please also see the ls_handler, which was itself obsoleted by ls2. 1490: # ls2_handler differs from ls_handler in that it escapes its return 1491: # values before concatenating them together with ':'s. 1492: # 1493: # ls2 - list the contents of a directory. For each file in the 1494: # selected directory the filename followed by the full output of 1495: # the stat function is returned. The returned info for each 1496: # file are separated by ':'. The stat fields are separated by &'s. 1497: # Parameters: 1498: # $cmd - The command that dispatched us (ls). 1499: # $ulsdir - The directory path to list... I'm not sure what this 1500: # is relative as things like ls:. return e.g. 1501: # no_such_dir. 1502: # $client - Socket open on the client. 1503: # Returns: 1504: # 1 - indicating that the daemon should not disconnect. 1505: # Side Effects: 1506: # The reply is written to $client. 1507: # 1508: sub ls2_handler { 1509: my ($cmd, $ulsdir, $client) = @_; 1510: 1511: my $userinput = "$cmd:$ulsdir"; 1512: 1513: my $obs; 1514: my $rights; 1515: my $ulsout=''; 1516: my $ulsfn; 1517: if (-e $ulsdir) { 1518: if(-d $ulsdir) { 1519: if (opendir(LSDIR,$ulsdir)) { 1520: while ($ulsfn=readdir(LSDIR)) { 1521: undef($obs); 1522: undef($rights); 1523: my @ulsstats=stat($ulsdir.'/'.$ulsfn); 1524: #We do some obsolete checking here 1525: if(-e $ulsdir.'/'.$ulsfn.".meta") { 1526: open(FILE, $ulsdir.'/'.$ulsfn.".meta"); 1527: my @obsolete=<FILE>; 1528: foreach my $obsolete (@obsolete) { 1529: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 1530: if($obsolete =~ m|(<copyright>)(default)|) { 1531: $rights = 1; 1532: } 1533: } 1534: } 1535: my $tmp = $ulsfn.'&'.join('&',@ulsstats); 1536: if ($obs eq '1') { $tmp.="&1"; } else { $tmp.="&0"; } 1537: if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; } 1538: $ulsout.= &escape($tmp).':'; 1539: } 1540: closedir(LSDIR); 1541: } 1542: } else { 1543: my @ulsstats=stat($ulsdir); 1544: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; 1545: } 1546: } else { 1547: $ulsout='no_such_dir'; 1548: } 1549: if ($ulsout eq '') { $ulsout='empty'; } 1550: &Reply($client, \$ulsout, $userinput); # This supports debug logging. 1551: return 1; 1552: } 1553: &register_handler("ls2", \&ls2_handler, 0, 1, 0); 1554: # 1555: # ls3 - list the contents of a directory. For each file in the 1556: # selected directory the filename followed by the full output of 1557: # the stat function is returned. The returned info for each 1558: # file are separated by ':'. The stat fields are separated by &'s. 1559: # Parameters: 1560: # $cmd - The command that dispatched us (ls). 1561: # $tail - The tail of the request that invoked us. 1562: # $tail is a : separated list of the following: 1563: # - $ulsdir - directory path to list (before prepending) 1564: # - $getpropath = 1 if &propath() should prepend 1565: # - $getuserdir = 1 if path to user dir in lonUsers should 1566: # prepend 1567: # - $alternate_root - path to prepend 1568: # - $uname - username to use for &propath or user dir 1569: # - $udom - domain to use for &propath or user dir 1570: # All of these except $getpropath and &getuserdir are escaped. 1571: # no_such_dir. 1572: # $client - Socket open on the client. 1573: # Returns: 1574: # 1 - indicating that the daemon should not disconnect. 1575: # Side Effects: 1576: # The reply is written to $client. 1577: # 1578: 1579: sub ls3_handler { 1580: my ($cmd, $tail, $client) = @_; 1581: my $userinput = "$cmd:$tail"; 1582: my ($ulsdir,$getpropath,$getuserdir,$alternate_root,$uname,$udom) = 1583: split(/:/,$tail); 1584: if (defined($ulsdir)) { 1585: $ulsdir = &unescape($ulsdir); 1586: } 1587: if (defined($alternate_root)) { 1588: $alternate_root = &unescape($alternate_root); 1589: } 1590: if (defined($uname)) { 1591: $uname = &unescape($uname); 1592: } 1593: if (defined($udom)) { 1594: $udom = &unescape($udom); 1595: } 1596: 1597: my $dir_root = $perlvar{'lonDocRoot'}; 1598: if ($getpropath) { 1599: if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) { 1600: $dir_root = &propath($udom,$uname); 1601: $dir_root =~ s/\/$//; 1602: } else { 1603: &Failure($client,"refused\n","$cmd:$tail"); 1604: return 1; 1605: } 1606: } elsif ($getuserdir) { 1607: if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) { 1608: my $subdir=$uname.'__'; 1609: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 1610: $dir_root = $Apache::lonnet::perlvar{'lonUsersDir'} 1611: ."/$udom/$subdir/$uname"; 1612: } else { 1613: &Failure($client,"refused\n","$cmd:$tail"); 1614: return 1; 1615: } 1616: } elsif ($alternate_root ne '') { 1617: $dir_root = $alternate_root; 1618: } 1619: if (($dir_root ne '') && ($dir_root ne '/')) { 1620: if ($ulsdir =~ /^\//) { 1621: $ulsdir = $dir_root.$ulsdir; 1622: } else { 1623: $ulsdir = $dir_root.'/'.$ulsdir; 1624: } 1625: } 1626: my $obs; 1627: my $rights; 1628: my $ulsout=''; 1629: my $ulsfn; 1630: if (-e $ulsdir) { 1631: if(-d $ulsdir) { 1632: if (opendir(LSDIR,$ulsdir)) { 1633: while ($ulsfn=readdir(LSDIR)) { 1634: undef($obs); 1635: undef($rights); 1636: my @ulsstats=stat($ulsdir.'/'.$ulsfn); 1637: #We do some obsolete checking here 1638: if(-e $ulsdir.'/'.$ulsfn.".meta") { 1639: open(FILE, $ulsdir.'/'.$ulsfn.".meta"); 1640: my @obsolete=<FILE>; 1641: foreach my $obsolete (@obsolete) { 1642: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 1643: if($obsolete =~ m|(<copyright>)(default)|) { 1644: $rights = 1; 1645: } 1646: } 1647: } 1648: my $tmp = $ulsfn.'&'.join('&',@ulsstats); 1649: if ($obs eq '1') { $tmp.="&1"; } else { $tmp.="&0"; } 1650: if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; } 1651: $ulsout.= &escape($tmp).':'; 1652: } 1653: closedir(LSDIR); 1654: } 1655: } else { 1656: my @ulsstats=stat($ulsdir); 1657: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; 1658: } 1659: } else { 1660: $ulsout='no_such_dir'; 1661: } 1662: if ($ulsout eq '') { $ulsout='empty'; } 1663: &Reply($client, \$ulsout, $userinput); # This supports debug logging. 1664: return 1; 1665: } 1666: &register_handler("ls3", \&ls3_handler, 0, 1, 0); 1667: 1668: sub read_lonnet_global { 1669: my ($cmd,$tail,$client) = @_; 1670: my $userinput = "$cmd:$tail"; 1671: my $requested = &Apache::lonnet::thaw_unescape($tail); 1672: my $result; 1673: my %packagevars = ( 1674: spareid => \%Apache::lonnet::spareid, 1675: perlvar => \%Apache::lonnet::perlvar, 1676: ); 1677: my %limit_to = ( 1678: perlvar => { 1679: lonOtherAuthen => 1, 1680: lonBalancer => 1, 1681: lonVersion => 1, 1682: lonSysEMail => 1, 1683: lonHostID => 1, 1684: lonRole => 1, 1685: lonDefDomain => 1, 1686: lonLoadLim => 1, 1687: lonUserLoadLim => 1, 1688: } 1689: ); 1690: if (ref($requested) eq 'HASH') { 1691: foreach my $what (keys(%{$requested})) { 1692: my $response; 1693: my $items = {}; 1694: if (exists($packagevars{$what})) { 1695: if (ref($limit_to{$what}) eq 'HASH') { 1696: foreach my $varname (keys(%{$packagevars{$what}})) { 1697: if ($limit_to{$what}{$varname}) { 1698: $items->{$varname} = $packagevars{$what}{$varname}; 1699: } 1700: } 1701: } else { 1702: $items = $packagevars{$what}; 1703: } 1704: if ($what eq 'perlvar') { 1705: if (!exists($packagevars{$what}{'lonBalancer'})) { 1706: if ($dist =~ /^(centos|rhes|fedora|scientific)/) { 1707: my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf'); 1708: if (ref($othervarref) eq 'HASH') { 1709: $items->{'lonBalancer'} = $othervarref->{'lonBalancer'}; 1710: } 1711: } 1712: } 1713: } 1714: $response = &Apache::lonnet::freeze_escape($items); 1715: } 1716: $result .= &escape($what).'='.$response.'&'; 1717: } 1718: } 1719: $result =~ s/\&$//; 1720: &Reply($client,\$result,$userinput); 1721: return 1; 1722: } 1723: &register_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0); 1724: 1725: sub server_devalidatecache_handler { 1726: my ($cmd,$tail,$client) = @_; 1727: my $userinput = "$cmd:$tail"; 1728: my $items = &unescape($tail); 1729: my @cached = split(/\&/,$items); 1730: foreach my $key (@cached) { 1731: if ($key =~ /:/) { 1732: my ($name,$id) = map { &unescape($_); } split(/:/,$key); 1733: &Apache::lonnet::devalidate_cache_new($name,$id); 1734: } 1735: } 1736: my $result = 'ok'; 1737: &Reply($client,\$result,$userinput); 1738: return 1; 1739: } 1740: &register_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0); 1741: 1742: sub server_timezone_handler { 1743: my ($cmd,$tail,$client) = @_; 1744: my $userinput = "$cmd:$tail"; 1745: my $timezone; 1746: my $clockfile = '/etc/sysconfig/clock'; # Fedora/CentOS/SuSE 1747: my $tzfile = '/etc/timezone'; # Debian/Ubuntu 1748: if (-e $clockfile) { 1749: if (open(my $fh,"<$clockfile")) { 1750: while (<$fh>) { 1751: next if (/^[\#\s]/); 1752: if (/^(?:TIME)?ZONE\s*=\s*['"]?\s*([\w\/]+)/) { 1753: $timezone = $1; 1754: last; 1755: } 1756: } 1757: close($fh); 1758: } 1759: } elsif (-e $tzfile) { 1760: if (open(my $fh,"<$tzfile")) { 1761: $timezone = <$fh>; 1762: close($fh); 1763: chomp($timezone); 1764: if ($timezone =~ m{^Etc/(\w+)$}) { 1765: $timezone = $1; 1766: } 1767: } 1768: } 1769: &Reply($client,\$timezone,$userinput); # This supports debug logging. 1770: return 1; 1771: } 1772: &register_handler("servertimezone", \&server_timezone_handler, 0, 1, 0); 1773: 1774: sub server_loncaparev_handler { 1775: my ($cmd,$tail,$client) = @_; 1776: my $userinput = "$cmd:$tail"; 1777: &Reply($client,\$perlvar{'lonVersion'},$userinput); 1778: return 1; 1779: } 1780: &register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0); 1781: 1782: sub server_homeID_handler { 1783: my ($cmd,$tail,$client) = @_; 1784: my $userinput = "$cmd:$tail"; 1785: &Reply($client,\$perlvar{'lonHostID'},$userinput); 1786: return 1; 1787: } 1788: &register_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0); 1789: 1790: sub server_distarch_handler { 1791: my ($cmd,$tail,$client) = @_; 1792: my $userinput = "$cmd:$tail"; 1793: my $reply = &distro_and_arch(); 1794: &Reply($client,\$reply,$userinput); 1795: return 1; 1796: } 1797: &register_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0); 1798: 1799: sub server_certs_handler { 1800: my ($cmd,$tail,$client) = @_; 1801: my $userinput = "$cmd:$tail"; 1802: my $result; 1803: my $result = &LONCAPA::Lond::server_certs(\%perlvar); 1804: &Reply($client,\$result,$userinput); 1805: return; 1806: } 1807: &register_handler("servercerts", \&server_certs_handler, 0, 1, 0); 1808: 1809: # Process a reinit request. Reinit requests that either 1810: # lonc or lond be reinitialized so that an updated 1811: # host.tab or domain.tab can be processed. 1812: # 1813: # Parameters: 1814: # $cmd - the actual keyword that invoked us. 1815: # $tail - the tail of the request that invoked us. 1816: # $client - File descriptor connected to the client 1817: # Returns: 1818: # 1 - Ok to continue processing. 1819: # 0 - Program should exit 1820: # Implicit output: 1821: # a reply is sent to the client. 1822: # 1823: sub reinit_process_handler { 1824: my ($cmd, $tail, $client) = @_; 1825: 1826: my $userinput = "$cmd:$tail"; 1827: 1828: my $cert = &GetCertificate($userinput); 1829: if(&ValidManager($cert)) { 1830: chomp($userinput); 1831: my $reply = &ReinitProcess($userinput); 1832: &Reply( $client, \$reply, $userinput); 1833: } else { 1834: &Failure( $client, "refused\n", $userinput); 1835: } 1836: return 1; 1837: } 1838: &register_handler("reinit", \&reinit_process_handler, 1, 0, 1); 1839: 1840: # Process the editing script for a table edit operation. 1841: # the editing operation must be encrypted and requested by 1842: # a manager host. 1843: # 1844: # Parameters: 1845: # $cmd - the actual keyword that invoked us. 1846: # $tail - the tail of the request that invoked us. 1847: # $client - File descriptor connected to the client 1848: # Returns: 1849: # 1 - Ok to continue processing. 1850: # 0 - Program should exit 1851: # Implicit output: 1852: # a reply is sent to the client. 1853: # 1854: sub edit_table_handler { 1855: my ($command, $tail, $client) = @_; 1856: 1857: my $userinput = "$command:$tail"; 1858: 1859: my $cert = &GetCertificate($userinput); 1860: if(&ValidManager($cert)) { 1861: my($filetype, $script) = split(/:/, $tail); 1862: if (($filetype eq "hosts") || 1863: ($filetype eq "domain")) { 1864: if($script ne "") { 1865: &Reply($client, # BUGBUG - EditFile 1866: &EditFile($userinput), # could fail. 1867: $userinput); 1868: } else { 1869: &Failure($client,"refused\n",$userinput); 1870: } 1871: } else { 1872: &Failure($client,"refused\n",$userinput); 1873: } 1874: } else { 1875: &Failure($client,"refused\n",$userinput); 1876: } 1877: return 1; 1878: } 1879: &register_handler("edit", \&edit_table_handler, 1, 0, 1); 1880: 1881: # 1882: # Authenticate a user against the LonCAPA authentication 1883: # database. Note that there are several authentication 1884: # possibilities: 1885: # - unix - The user can be authenticated against the unix 1886: # password file. 1887: # - internal - The user can be authenticated against a purely 1888: # internal per user password file. 1889: # - kerberos - The user can be authenticated against either a kerb4 or kerb5 1890: # ticket granting authority. 1891: # - user - The person tailoring LonCAPA can supply a user authentication 1892: # mechanism that is per system. 1893: # 1894: # Parameters: 1895: # $cmd - The command that got us here. 1896: # $tail - Tail of the command (remaining parameters). 1897: # $client - File descriptor connected to client. 1898: # Returns 1899: # 0 - Requested to exit, caller should shut down. 1900: # 1 - Continue processing. 1901: # Implicit inputs: 1902: # The authentication systems describe above have their own forms of implicit 1903: # input into the authentication process that are described above. 1904: # 1905: sub authenticate_handler { 1906: my ($cmd, $tail, $client) = @_; 1907: 1908: 1909: # Regenerate the full input line 1910: 1911: my $userinput = $cmd.":".$tail; 1912: 1913: # udom - User's domain. 1914: # uname - Username. 1915: # upass - User's password. 1916: # checkdefauth - Pass to validate_user() to try authentication 1917: # with default auth type(s) if no user account. 1918: # clientcancheckhost - Passed by clients with functionality in lonauth.pm 1919: # to check if session can be hosted. 1920: 1921: my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail); 1922: &Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth"); 1923: chomp($upass); 1924: $upass=&unescape($upass); 1925: 1926: my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth); 1927: if($pwdcorrect) { 1928: my $canhost = 1; 1929: unless ($clientcancheckhost) { 1930: my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); 1931: my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); 1932: my @intdoms; 1933: my $internet_names = &Apache::lonnet::get_internet_names($clientname); 1934: if (ref($internet_names) eq 'ARRAY') { 1935: @intdoms = @{$internet_names}; 1936: } 1937: unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) { 1938: my ($remote,$hosted); 1939: my $remotesession = &get_usersession_config($udom,'remotesession'); 1940: if (ref($remotesession) eq 'HASH') { 1941: $remote = $remotesession->{'remote'} 1942: } 1943: my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession'); 1944: if (ref($hostedsession) eq 'HASH') { 1945: $hosted = $hostedsession->{'hosted'}; 1946: } 1947: $canhost = &Apache::lonnet::can_host_session($udom,$clientname, 1948: $clientversion, 1949: $remote,$hosted); 1950: } 1951: } 1952: if ($canhost) { 1953: &Reply( $client, "authorized\n", $userinput); 1954: } else { 1955: &Reply( $client, "not_allowed_to_host\n", $userinput); 1956: } 1957: # 1958: # Bad credentials: Failed to authorize 1959: # 1960: } else { 1961: &Failure( $client, "non_authorized\n", $userinput); 1962: } 1963: 1964: return 1; 1965: } 1966: &register_handler("auth", \&authenticate_handler, 1, 1, 0); 1967: 1968: # 1969: # Change a user's password. Note that this function is complicated by 1970: # the fact that a user may be authenticated in more than one way: 1971: # At present, we are not able to change the password for all types of 1972: # authentication methods. Only for: 1973: # unix - unix password or shadow passoword style authentication. 1974: # local - Locally written authentication mechanism. 1975: # For now, kerb4 and kerb5 password changes are not supported and result 1976: # in an error. 1977: # FUTURE WORK: 1978: # Support kerberos passwd changes? 1979: # Parameters: 1980: # $cmd - The command that got us here. 1981: # $tail - Tail of the command (remaining parameters). 1982: # $client - File descriptor connected to client. 1983: # Returns 1984: # 0 - Requested to exit, caller should shut down. 1985: # 1 - Continue processing. 1986: # Implicit inputs: 1987: # The authentication systems describe above have their own forms of implicit 1988: # input into the authentication process that are described above. 1989: sub change_password_handler { 1990: my ($cmd, $tail, $client) = @_; 1991: 1992: my $userinput = $cmd.":".$tail; # Reconstruct client's string. 1993: 1994: # 1995: # udom - user's domain. 1996: # uname - Username. 1997: # upass - Current password. 1998: # npass - New password. 1999: # context - Context in which this was called 2000: # (preferences or reset_by_email). 2001: # lonhost - HostID of server where request originated 2002: 2003: my ($udom,$uname,$upass,$npass,$context,$lonhost)=split(/:/,$tail); 2004: 2005: $upass=&unescape($upass); 2006: $npass=&unescape($npass); 2007: &Debug("Trying to change password for $uname"); 2008: 2009: # First require that the user can be authenticated with their 2010: # old password unless context was 'reset_by_email': 2011: 2012: my ($validated,$failure); 2013: if ($context eq 'reset_by_email') { 2014: if ($lonhost eq '') { 2015: $failure = 'invalid_client'; 2016: } else { 2017: $validated = 1; 2018: } 2019: } else { 2020: $validated = &validate_user($udom, $uname, $upass); 2021: } 2022: if($validated) { 2023: my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd. 2024: 2025: my ($howpwd,$contentpwd)=split(/:/,$realpasswd); 2026: if ($howpwd eq 'internal') { 2027: &Debug("internal auth"); 2028: my $ncpass = &hash_passwd($udom,$npass); 2029: if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) { 2030: my $msg="Result of password change for $uname: pwchange_success"; 2031: if ($lonhost) { 2032: $msg .= " - request originated from: $lonhost"; 2033: } 2034: &logthis($msg); 2035: &update_passwd_history($uname,$udom,$howpwd,$context); 2036: &Reply($client, "ok\n", $userinput); 2037: } else { 2038: &logthis("Unable to open $uname passwd " 2039: ."to change password"); 2040: &Failure( $client, "non_authorized\n",$userinput); 2041: } 2042: } elsif ($howpwd eq 'unix' && $context ne 'reset_by_email') { 2043: my $result = &change_unix_password($uname, $npass); 2044: if ($result eq 'ok') { 2045: &update_passwd_history($uname,$udom,$howpwd,$context); 2046: } 2047: &logthis("Result of password change for $uname: ". 2048: $result); 2049: &Reply($client, \$result, $userinput); 2050: } else { 2051: # this just means that the current password mode is not 2052: # one we know how to change (e.g the kerberos auth modes or 2053: # locally written auth handler). 2054: # 2055: &Failure( $client, "auth_mode_error\n", $userinput); 2056: } 2057: 2058: } else { 2059: if ($failure eq '') { 2060: $failure = 'non_authorized'; 2061: } 2062: &Failure( $client, "$failure\n", $userinput); 2063: } 2064: 2065: return 1; 2066: } 2067: &register_handler("passwd", \&change_password_handler, 1, 1, 0); 2068: 2069: sub hash_passwd { 2070: my ($domain,$plainpass,@rest) = @_; 2071: my ($salt,$cost); 2072: if (@rest) { 2073: $cost = $rest[0]; 2074: # salt is first 22 characters, base-64 encoded by bcrypt 2075: my $plainsalt = substr($rest[1],0,22); 2076: $salt = Crypt::Eksblowfish::Bcrypt::de_base64($plainsalt); 2077: } else { 2078: my $defaultcost; 2079: my %domconfig = 2080: &Apache::lonnet::get_dom('configuration',['password'],$domain); 2081: if (ref($domconfig{'password'}) eq 'HASH') { 2082: $defaultcost = $domconfig{'password'}{'cost'}; 2083: } 2084: if (($defaultcost eq '') || ($defaultcost =~ /D/)) { 2085: $cost = 10; 2086: } else { 2087: $cost = $defaultcost; 2088: } 2089: # Generate random 16-octet base64 salt 2090: $salt = ""; 2091: $salt .= pack("C", int rand(256)) for 1..16; 2092: } 2093: my $hash = &Crypt::Eksblowfish::Bcrypt::bcrypt_hash({ 2094: key_nul => 1, 2095: cost => $cost, 2096: salt => $salt, 2097: }, Digest::SHA::sha512(Encode::encode('UTF-8',$plainpass))); 2098: 2099: my $result = join("!", "", "bcrypt", sprintf("%02d",$cost), 2100: &Crypt::Eksblowfish::Bcrypt::en_base64($salt). 2101: &Crypt::Eksblowfish::Bcrypt::en_base64($hash)); 2102: return $result; 2103: } 2104: 2105: # 2106: # Create a new user. User in this case means a lon-capa user. 2107: # The user must either already exist in some authentication realm 2108: # like kerberos or the /etc/passwd. If not, a user completely local to 2109: # this loncapa system is created. 2110: # 2111: # Parameters: 2112: # $cmd - The command that got us here. 2113: # $tail - Tail of the command (remaining parameters). 2114: # $client - File descriptor connected to client. 2115: # Returns 2116: # 0 - Requested to exit, caller should shut down. 2117: # 1 - Continue processing. 2118: # Implicit inputs: 2119: # The authentication systems describe above have their own forms of implicit 2120: # input into the authentication process that are described above. 2121: sub add_user_handler { 2122: 2123: my ($cmd, $tail, $client) = @_; 2124: 2125: 2126: my ($udom,$uname,$umode,$npass)=split(/:/,$tail); 2127: my $userinput = $cmd.":".$tail; # Reconstruct the full request line. 2128: 2129: &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname); 2130: 2131: 2132: if($udom eq $currentdomainid) { # Reject new users for other domains... 2133: 2134: my $oldumask=umask(0077); 2135: chomp($npass); 2136: $npass=&unescape($npass); 2137: my $passfilename = &password_path($udom, $uname); 2138: &Debug("Password file created will be:".$passfilename); 2139: if (-e $passfilename) { 2140: &Failure( $client, "already_exists\n", $userinput); 2141: } else { 2142: my $fperror=''; 2143: if (!&mkpath($passfilename)) { 2144: $fperror="error: ".($!+0)." mkdir failed while attempting " 2145: ."makeuser"; 2146: } 2147: unless ($fperror) { 2148: my $result=&make_passwd_file($uname,$udom,$umode,$npass, 2149: $passfilename,'makeuser'); 2150: &Reply($client,\$result, $userinput); #BUGBUG - could be fail 2151: } else { 2152: &Failure($client, \$fperror, $userinput); 2153: } 2154: } 2155: umask($oldumask); 2156: } else { 2157: &Failure($client, "not_right_domain\n", 2158: $userinput); # Even if we are multihomed. 2159: 2160: } 2161: return 1; 2162: 2163: } 2164: &register_handler("makeuser", \&add_user_handler, 1, 1, 0); 2165: 2166: # 2167: # Change the authentication method of a user. Note that this may 2168: # also implicitly change the user's password if, for example, the user is 2169: # joining an existing authentication realm. Known authentication realms at 2170: # this time are: 2171: # internal - Purely internal password file (only loncapa knows this user) 2172: # local - Institutionally written authentication module. 2173: # unix - Unix user (/etc/passwd with or without /etc/shadow). 2174: # kerb4 - kerberos version 4 2175: # kerb5 - kerberos version 5 2176: # 2177: # Parameters: 2178: # $cmd - The command that got us here. 2179: # $tail - Tail of the command (remaining parameters). 2180: # $client - File descriptor connected to client. 2181: # Returns 2182: # 0 - Requested to exit, caller should shut down. 2183: # 1 - Continue processing. 2184: # Implicit inputs: 2185: # The authentication systems describe above have their own forms of implicit 2186: # input into the authentication process that are described above. 2187: # NOTE: 2188: # This is also used to change the authentication credential values (e.g. passwd). 2189: # 2190: # 2191: sub change_authentication_handler { 2192: 2193: my ($cmd, $tail, $client) = @_; 2194: 2195: my $userinput = "$cmd:$tail"; # Reconstruct user input. 2196: 2197: my ($udom,$uname,$umode,$npass)=split(/:/,$tail); 2198: &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode); 2199: if ($udom ne $currentdomainid) { 2200: &Failure( $client, "not_right_domain\n", $client); 2201: } else { 2202: 2203: chomp($npass); 2204: 2205: $npass=&unescape($npass); 2206: my $oldauth = &get_auth_type($udom, $uname); # Get old auth info. 2207: my $passfilename = &password_path($udom, $uname); 2208: if ($passfilename) { # Not allowed to create a new user!! 2209: # If just changing the unix passwd. need to arrange to run 2210: # passwd since otherwise make_passwd_file will fail as 2211: # creation of unix authenticated users is no longer supported 2212: # except from the command line, when running make_domain_coordinator.pl 2213: 2214: if(($oldauth =~/^unix/) && ($umode eq "unix")) { 2215: my $result = &change_unix_password($uname, $npass); 2216: &logthis("Result of password change for $uname: ".$result); 2217: if ($result eq "ok") { 2218: &update_passwd_history($uname,$udom,$umode,'changeuserauth'); 2219: &Reply($client, \$result); 2220: } else { 2221: &Failure($client, \$result); 2222: } 2223: } else { 2224: my $result=&make_passwd_file($uname,$udom,$umode,$npass, 2225: $passfilename,'changeuserauth'); 2226: # 2227: # If the current auth mode is internal, and the old auth mode was 2228: # unix, or krb*, and the user is an author for this domain, 2229: # re-run manage_permissions for that role in order to be able 2230: # to take ownership of the construction space back to www:www 2231: # 2232: 2233: 2234: &Reply($client, \$result, $userinput); 2235: } 2236: 2237: 2238: } else { 2239: &Failure($client, "non_authorized\n", $userinput); # Fail the user now. 2240: } 2241: } 2242: return 1; 2243: } 2244: &register_handler("changeuserauth", \&change_authentication_handler, 1,1, 0); 2245: 2246: sub update_passwd_history { 2247: my ($uname,$udom,$umode,$context) = @_; 2248: my $proname=&propath($udom,$uname); 2249: my $now = time; 2250: if (open(my $fh,">>$proname/passwd.log")) { 2251: print $fh "$now:$umode:$context\n"; 2252: close($fh); 2253: } 2254: return; 2255: } 2256: 2257: # 2258: # Determines if this is the home server for a user. The home server 2259: # for a user will have his/her lon-capa passwd file. Therefore all we need 2260: # to do is determine if this file exists. 2261: # 2262: # Parameters: 2263: # $cmd - The command that got us here. 2264: # $tail - Tail of the command (remaining parameters). 2265: # $client - File descriptor connected to client. 2266: # Returns 2267: # 0 - Requested to exit, caller should shut down. 2268: # 1 - Continue processing. 2269: # Implicit inputs: 2270: # The authentication systems describe above have their own forms of implicit 2271: # input into the authentication process that are described above. 2272: # 2273: sub is_home_handler { 2274: my ($cmd, $tail, $client) = @_; 2275: 2276: my $userinput = "$cmd:$tail"; 2277: 2278: my ($udom,$uname)=split(/:/,$tail); 2279: chomp($uname); 2280: my $passfile = &password_filename($udom, $uname); 2281: if($passfile) { 2282: &Reply( $client, "found\n", $userinput); 2283: } else { 2284: &Failure($client, "not_found\n", $userinput); 2285: } 2286: return 1; 2287: } 2288: &register_handler("home", \&is_home_handler, 0,1,0); 2289: 2290: # 2291: # Process an update request for a resource. 2292: # A resource has been modified that we hold a subscription to. 2293: # If the resource is not local, then we must update, or at least invalidate our 2294: # cached copy of the resource. 2295: # Parameters: 2296: # $cmd - The command that got us here. 2297: # $tail - Tail of the command (remaining parameters). 2298: # $client - File descriptor connected to client. 2299: # Returns 2300: # 0 - Requested to exit, caller should shut down. 2301: # 1 - Continue processing. 2302: # Implicit inputs: 2303: # The authentication systems describe above have their own forms of implicit 2304: # input into the authentication process that are described above. 2305: # 2306: sub update_resource_handler { 2307: 2308: my ($cmd, $tail, $client) = @_; 2309: 2310: my $userinput = "$cmd:$tail"; 2311: 2312: my $fname= $tail; # This allows interactive testing 2313: 2314: 2315: my $ownership=ishome($fname); 2316: if ($ownership eq 'not_owner') { 2317: if (-e $fname) { 2318: # Delete preview file, if exists 2319: unlink("$fname.tmp"); 2320: # Get usage stats 2321: my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, 2322: $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname); 2323: my $now=time; 2324: my $since=$now-$atime; 2325: # If the file has not been used within lonExpire seconds, 2326: # unsubscribe from it and delete local copy 2327: if ($since>$perlvar{'lonExpire'}) { 2328: my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname"); 2329: &devalidate_meta_cache($fname); 2330: unlink("$fname"); 2331: unlink("$fname.meta"); 2332: } else { 2333: # Yes, this is in active use. Get a fresh copy. Since it might be in 2334: # very active use and huge (like a movie), copy it to "in.transfer" filename first. 2335: my $transname="$fname.in.transfer"; 2336: my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname"); 2337: my $response; 2338: # FIXME: cannot replicate files that take more than two minutes to transfer? 2339: # alarm(120); 2340: # FIXME: this should use the LWP mechanism, not internal alarms. 2341: alarm(1200); 2342: { 2343: my $request=new HTTP::Request('GET',"$remoteurl"); 2344: $response=&LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,0,1); 2345: } 2346: alarm(0); 2347: if ($response->is_error()) { 2348: # FIXME: we should probably clean up here instead of just whine 2349: unlink($transname); 2350: my $message=$response->status_line; 2351: &logthis("LWP GET: $message for $fname ($remoteurl)"); 2352: } else { 2353: if ($remoteurl!~/\.meta$/) { 2354: # FIXME: isn't there an internal LWP mechanism for this? 2355: alarm(120); 2356: { 2357: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); 2358: my $mresponse = &LONCAPA::LWPReq::makerequest($clientname,$mrequest,$fname.'.meta',\%perlvar,120,0,1); 2359: if ($mresponse->is_error()) { 2360: unlink($fname.'.meta'); 2361: } 2362: } 2363: alarm(0); 2364: } 2365: # we successfully transfered, copy file over to real name 2366: rename($transname,$fname); 2367: &devalidate_meta_cache($fname); 2368: } 2369: } 2370: &Reply( $client, "ok\n", $userinput); 2371: } else { 2372: &Failure($client, "not_found\n", $userinput); 2373: } 2374: } else { 2375: &Failure($client, "rejected\n", $userinput); 2376: } 2377: return 1; 2378: } 2379: &register_handler("update", \&update_resource_handler, 0 ,1, 0); 2380: 2381: sub devalidate_meta_cache { 2382: my ($url) = @_; 2383: use Cache::Memcached; 2384: my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); 2385: $url = &Apache::lonnet::declutter($url); 2386: $url =~ s-\.meta$--; 2387: my $id = &escape('meta:'.$url); 2388: $memcache->delete($id); 2389: } 2390: 2391: # 2392: # Fetch a user file from a remote server to the user's home directory 2393: # userfiles subdir. 2394: # Parameters: 2395: # $cmd - The command that got us here. 2396: # $tail - Tail of the command (remaining parameters). 2397: # $client - File descriptor connected to client. 2398: # Returns 2399: # 0 - Requested to exit, caller should shut down. 2400: # 1 - Continue processing. 2401: # 2402: sub fetch_user_file_handler { 2403: 2404: my ($cmd, $tail, $client) = @_; 2405: 2406: my $userinput = "$cmd:$tail"; 2407: my $fname = $tail; 2408: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); 2409: my $udir=&propath($udom,$uname).'/userfiles'; 2410: unless (-e $udir) { 2411: mkdir($udir,0770); 2412: } 2413: Debug("fetch user file for $fname"); 2414: if (-e $udir) { 2415: $ufile=~s/^[\.\~]+//; 2416: 2417: # IF necessary, create the path right down to the file. 2418: # Note that any regular files in the way of this path are 2419: # wiped out to deal with some earlier folly of mine. 2420: 2421: if (!&mkpath($udir.'/'.$ufile)) { 2422: &Failure($client, "unable_to_create\n", $userinput); 2423: } 2424: 2425: my $destname=$udir.'/'.$ufile; 2426: my $transname=$udir.'/'.$ufile.'.in.transit'; 2427: my $clientprotocol=$Apache::lonnet::protocol{$clientname}; 2428: $clientprotocol = 'http' if ($clientprotocol ne 'https'); 2429: my $clienthost = &Apache::lonnet::hostname($clientname); 2430: my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname; 2431: my $response; 2432: Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname"); 2433: alarm(1200); 2434: { 2435: my $request=new HTTP::Request('GET',"$remoteurl"); 2436: my $verifycert = 1; 2437: my @machine_ids = &Apache::lonnet::current_machine_ids(); 2438: if (grep(/^\Q$clientname\E$/,@machine_ids)) { 2439: $verifycert = 0; 2440: } 2441: $response = &LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,$verifycert); 2442: } 2443: alarm(0); 2444: if ($response->is_error()) { 2445: unlink($transname); 2446: my $message=$response->status_line; 2447: &logthis("LWP GET: $message for $fname ($remoteurl)"); 2448: &Failure($client, "failed\n", $userinput); 2449: } else { 2450: Debug("Renaming $transname to $destname"); 2451: if (!rename($transname,$destname)) { 2452: &logthis("Unable to move $transname to $destname"); 2453: unlink($transname); 2454: &Failure($client, "failed\n", $userinput); 2455: } else { 2456: if ($fname =~ /^default.+\.(page|sequence)$/) { 2457: my ($major,$minor) = split(/\./,$clientversion); 2458: if (($major < 2) || ($major == 2 && $minor < 11)) { 2459: my $now = time; 2460: &Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600); 2461: my $key = &escape('internal.contentchange'); 2462: my $what = "$key=$now"; 2463: my $hashref = &tie_user_hash($udom,$uname,'environment', 2464: &GDBM_WRCREAT(),"P",$what); 2465: if ($hashref) { 2466: $hashref->{$key}=$now; 2467: if (!&untie_user_hash($hashref)) { 2468: &logthis("error: ".($!+0)." untie (GDBM) failed ". 2469: "when updating internal.contentchange"); 2470: } 2471: } 2472: } 2473: } 2474: &Reply($client, "ok\n", $userinput); 2475: } 2476: } 2477: } else { 2478: &Failure($client, "not_home\n", $userinput); 2479: } 2480: return 1; 2481: } 2482: &register_handler("fetchuserfile", \&fetch_user_file_handler, 0, 1, 0); 2483: 2484: # 2485: # Remove a file from a user's home directory userfiles subdirectory. 2486: # Parameters: 2487: # cmd - the Lond request keyword that got us here. 2488: # tail - the part of the command past the keyword. 2489: # client- File descriptor connected with the client. 2490: # 2491: # Returns: 2492: # 1 - Continue processing. 2493: sub remove_user_file_handler { 2494: my ($cmd, $tail, $client) = @_; 2495: 2496: my ($fname) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent. 2497: 2498: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|); 2499: if ($ufile =~m|/\.\./|) { 2500: # any files paths with /../ in them refuse 2501: # to deal with 2502: &Failure($client, "refused\n", "$cmd:$tail"); 2503: } else { 2504: my $udir = &propath($udom,$uname); 2505: if (-e $udir) { 2506: my $file=$udir.'/userfiles/'.$ufile; 2507: if (-e $file) { 2508: # 2509: # If the file is a regular file unlink is fine... 2510: # However it's possible the client wants a dir 2511: # removed, in which case rmdir is more appropriate. 2512: # Note: rmdir will only remove an empty directory. 2513: # 2514: if (-f $file){ 2515: unlink($file); 2516: # for html files remove the associated .bak file 2517: # which may have been created by the editor. 2518: if ($ufile =~ m{^((docs|supplemental)/(?:\d+|default)/\d+(?:|/.+)/)[^/]+\.x?html?$}i) { 2519: my $path = $1; 2520: if (-e $file.'.bak') { 2521: unlink($file.'.bak'); 2522: } 2523: } 2524: } elsif(-d $file) { 2525: rmdir($file); 2526: } 2527: if (-e $file) { 2528: # File is still there after we deleted it ?!? 2529: 2530: &Failure($client, "failed\n", "$cmd:$tail"); 2531: } else { 2532: &Reply($client, "ok\n", "$cmd:$tail"); 2533: } 2534: } else { 2535: &Failure($client, "not_found\n", "$cmd:$tail"); 2536: } 2537: } else { 2538: &Failure($client, "not_home\n", "$cmd:$tail"); 2539: } 2540: } 2541: return 1; 2542: } 2543: &register_handler("removeuserfile", \&remove_user_file_handler, 0,1,0); 2544: 2545: # 2546: # make a directory in a user's home directory userfiles subdirectory. 2547: # Parameters: 2548: # cmd - the Lond request keyword that got us here. 2549: # tail - the part of the command past the keyword. 2550: # client- File descriptor connected with the client. 2551: # 2552: # Returns: 2553: # 1 - Continue processing. 2554: sub mkdir_user_file_handler { 2555: my ($cmd, $tail, $client) = @_; 2556: 2557: my ($dir) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent. 2558: $dir=&unescape($dir); 2559: my ($udom,$uname,$ufile) = ($dir =~ m|^([^/]+)/([^/]+)/(.+)$|); 2560: if ($ufile =~m|/\.\./|) { 2561: # any files paths with /../ in them refuse 2562: # to deal with 2563: &Failure($client, "refused\n", "$cmd:$tail"); 2564: } else { 2565: my $udir = &propath($udom,$uname); 2566: if (-e $udir) { 2567: my $newdir=$udir.'/userfiles/'.$ufile.'/'; 2568: if (!&mkpath($newdir)) { 2569: &Failure($client, "failed\n", "$cmd:$tail"); 2570: } 2571: &Reply($client, "ok\n", "$cmd:$tail"); 2572: } else { 2573: &Failure($client, "not_home\n", "$cmd:$tail"); 2574: } 2575: } 2576: return 1; 2577: } 2578: &register_handler("mkdiruserfile", \&mkdir_user_file_handler, 0,1,0); 2579: 2580: # 2581: # rename a file in a user's home directory userfiles subdirectory. 2582: # Parameters: 2583: # cmd - the Lond request keyword that got us here. 2584: # tail - the part of the command past the keyword. 2585: # client- File descriptor connected with the client. 2586: # 2587: # Returns: 2588: # 1 - Continue processing. 2589: sub rename_user_file_handler { 2590: my ($cmd, $tail, $client) = @_; 2591: 2592: my ($udom,$uname,$old,$new) = split(/:/, $tail); 2593: $old=&unescape($old); 2594: $new=&unescape($new); 2595: if ($new =~m|/\.\./| || $old =~m|/\.\./|) { 2596: # any files paths with /../ in them refuse to deal with 2597: &Failure($client, "refused\n", "$cmd:$tail"); 2598: } else { 2599: my $udir = &propath($udom,$uname); 2600: if (-e $udir) { 2601: my $oldfile=$udir.'/userfiles/'.$old; 2602: my $newfile=$udir.'/userfiles/'.$new; 2603: if (-e $newfile) { 2604: &Failure($client, "exists\n", "$cmd:$tail"); 2605: } elsif (! -e $oldfile) { 2606: &Failure($client, "not_found\n", "$cmd:$tail"); 2607: } else { 2608: if (!rename($oldfile,$newfile)) { 2609: &Failure($client, "failed\n", "$cmd:$tail"); 2610: } else { 2611: &Reply($client, "ok\n", "$cmd:$tail"); 2612: } 2613: } 2614: } else { 2615: &Failure($client, "not_home\n", "$cmd:$tail"); 2616: } 2617: } 2618: return 1; 2619: } 2620: &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0); 2621: 2622: # 2623: # Checks if the specified user has an active session on the server 2624: # return ok if so, not_found if not 2625: # 2626: # Parameters: 2627: # cmd - The request keyword that dispatched to tus. 2628: # tail - The tail of the request (colon separated parameters). 2629: # client - Filehandle open on the client. 2630: # Return: 2631: # 1. 2632: sub user_has_session_handler { 2633: my ($cmd, $tail, $client) = @_; 2634: 2635: my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail)); 2636: 2637: opendir(DIR,$perlvar{'lonIDsDir'}); 2638: my $filename; 2639: while ($filename=readdir(DIR)) { 2640: last if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/); 2641: } 2642: if ($filename) { 2643: &Reply($client, "ok\n", "$cmd:$tail"); 2644: } else { 2645: &Failure($client, "not_found\n", "$cmd:$tail"); 2646: } 2647: return 1; 2648: 2649: } 2650: &register_handler("userhassession", \&user_has_session_handler, 0,1,0); 2651: 2652: # 2653: # Authenticate access to a user file by checking that the token the user's 2654: # passed also exists in their session file 2655: # 2656: # Parameters: 2657: # cmd - The request keyword that dispatched to tus. 2658: # tail - The tail of the request (colon separated parameters). 2659: # client - Filehandle open on the client. 2660: # Return: 2661: # 1. 2662: sub token_auth_user_file_handler { 2663: my ($cmd, $tail, $client) = @_; 2664: 2665: my ($fname, $session) = split(/:/, $tail); 2666: 2667: chomp($session); 2668: my $reply="non_auth"; 2669: my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id'; 2670: if (open(ENVIN,"$file")) { 2671: flock(ENVIN,LOCK_SH); 2672: tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640); 2673: if (exists($disk_env{"userfile.$fname"})) { 2674: $reply="ok"; 2675: } else { 2676: foreach my $envname (keys(%disk_env)) { 2677: if ($envname=~ m|^userfile\.\Q$fname\E|) { 2678: $reply="ok"; 2679: last; 2680: } 2681: } 2682: } 2683: untie(%disk_env); 2684: close(ENVIN); 2685: &Reply($client, \$reply, "$cmd:$tail"); 2686: } else { 2687: &Failure($client, "invalid_token\n", "$cmd:$tail"); 2688: } 2689: return 1; 2690: 2691: } 2692: &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0); 2693: 2694: # 2695: # Unsubscribe from a resource. 2696: # 2697: # Parameters: 2698: # $cmd - The command that got us here. 2699: # $tail - Tail of the command (remaining parameters). 2700: # $client - File descriptor connected to client. 2701: # Returns 2702: # 0 - Requested to exit, caller should shut down. 2703: # 1 - Continue processing. 2704: # 2705: sub unsubscribe_handler { 2706: my ($cmd, $tail, $client) = @_; 2707: 2708: my $userinput= "$cmd:$tail"; 2709: 2710: my ($fname) = split(/:/,$tail); # Split in case there's extrs. 2711: 2712: &Debug("Unsubscribing $fname"); 2713: if (-e $fname) { 2714: &Debug("Exists"); 2715: &Reply($client, &unsub($fname,$clientip), $userinput); 2716: } else { 2717: &Failure($client, "not_found\n", $userinput); 2718: } 2719: return 1; 2720: } 2721: &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0); 2722: 2723: # Subscribe to a resource 2724: # 2725: # Parameters: 2726: # $cmd - The command that got us here. 2727: # $tail - Tail of the command (remaining parameters). 2728: # $client - File descriptor connected to client. 2729: # Returns 2730: # 0 - Requested to exit, caller should shut down. 2731: # 1 - Continue processing. 2732: # 2733: sub subscribe_handler { 2734: my ($cmd, $tail, $client)= @_; 2735: 2736: my $userinput = "$cmd:$tail"; 2737: 2738: &Reply( $client, &subscribe($userinput,$clientip), $userinput); 2739: 2740: return 1; 2741: } 2742: &register_handler("sub", \&subscribe_handler, 0, 1, 0); 2743: 2744: # 2745: # Determine the latest version of a resource (it looks for the highest 2746: # past version and then returns that +1) 2747: # 2748: # Parameters: 2749: # $cmd - The command that got us here. 2750: # $tail - Tail of the command (remaining parameters). 2751: # (Should consist of an absolute path to a file) 2752: # $client - File descriptor connected to client. 2753: # Returns 2754: # 0 - Requested to exit, caller should shut down. 2755: # 1 - Continue processing. 2756: # 2757: sub current_version_handler { 2758: my ($cmd, $tail, $client) = @_; 2759: 2760: my $userinput= "$cmd:$tail"; 2761: 2762: my $fname = $tail; 2763: &Reply( $client, &currentversion($fname)."\n", $userinput); 2764: return 1; 2765: 2766: } 2767: &register_handler("currentversion", \&current_version_handler, 0, 1, 0); 2768: 2769: # Make an entry in a user's activity log. 2770: # 2771: # Parameters: 2772: # $cmd - The command that got us here. 2773: # $tail - Tail of the command (remaining parameters). 2774: # $client - File descriptor connected to client. 2775: # Returns 2776: # 0 - Requested to exit, caller should shut down. 2777: # 1 - Continue processing. 2778: # 2779: sub activity_log_handler { 2780: my ($cmd, $tail, $client) = @_; 2781: 2782: 2783: my $userinput= "$cmd:$tail"; 2784: 2785: my ($udom,$uname,$what)=split(/:/,$tail); 2786: chomp($what); 2787: my $proname=&propath($udom,$uname); 2788: my $now=time; 2789: my $hfh; 2790: if ($hfh=IO::File->new(">>$proname/activity.log")) { 2791: print $hfh "$now:$clientname:$what\n"; 2792: &Reply( $client, "ok\n", $userinput); 2793: } else { 2794: &Failure($client, "error: ".($!+0)." IO::File->new Failed " 2795: ."while attempting log\n", 2796: $userinput); 2797: } 2798: 2799: return 1; 2800: } 2801: &register_handler("log", \&activity_log_handler, 0, 1, 0); 2802: 2803: # 2804: # Put a namespace entry in a user profile hash. 2805: # My druthers would be for this to be an encrypted interaction too. 2806: # anything that might be an inadvertent covert channel about either 2807: # user authentication or user personal information.... 2808: # 2809: # Parameters: 2810: # $cmd - The command that got us here. 2811: # $tail - Tail of the command (remaining parameters). 2812: # $client - File descriptor connected to client. 2813: # Returns 2814: # 0 - Requested to exit, caller should shut down. 2815: # 1 - Continue processing. 2816: # 2817: sub put_user_profile_entry { 2818: my ($cmd, $tail, $client) = @_; 2819: 2820: my $userinput = "$cmd:$tail"; 2821: 2822: my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4); 2823: if ($namespace ne 'roles') { 2824: chomp($what); 2825: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2826: &GDBM_WRCREAT(),"P",$what); 2827: if($hashref) { 2828: my @pairs=split(/\&/,$what); 2829: foreach my $pair (@pairs) { 2830: my ($key,$value)=split(/=/,$pair); 2831: $hashref->{$key}=$value; 2832: } 2833: if (&untie_user_hash($hashref)) { 2834: &Reply( $client, "ok\n", $userinput); 2835: } else { 2836: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". 2837: "while attempting put\n", 2838: $userinput); 2839: } 2840: } else { 2841: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2842: "while attempting put\n", $userinput); 2843: } 2844: } else { 2845: &Failure( $client, "refused\n", $userinput); 2846: } 2847: 2848: return 1; 2849: } 2850: &register_handler("put", \&put_user_profile_entry, 0, 1, 0); 2851: 2852: # Put a piece of new data in hash, returns error if entry already exists 2853: # Parameters: 2854: # $cmd - The command that got us here. 2855: # $tail - Tail of the command (remaining parameters). 2856: # $client - File descriptor connected to client. 2857: # Returns 2858: # 0 - Requested to exit, caller should shut down. 2859: # 1 - Continue processing. 2860: # 2861: sub newput_user_profile_entry { 2862: my ($cmd, $tail, $client) = @_; 2863: 2864: my $userinput = "$cmd:$tail"; 2865: 2866: my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4); 2867: if ($namespace eq 'roles') { 2868: &Failure( $client, "refused\n", $userinput); 2869: return 1; 2870: } 2871: 2872: chomp($what); 2873: 2874: my $hashref = &tie_user_hash($udom, $uname, $namespace, 2875: &GDBM_WRCREAT(),"N",$what); 2876: if(!$hashref) { 2877: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2878: "while attempting put\n", $userinput); 2879: return 1; 2880: } 2881: 2882: my @pairs=split(/\&/,$what); 2883: foreach my $pair (@pairs) { 2884: my ($key,$value)=split(/=/,$pair); 2885: if (exists($hashref->{$key})) { 2886: if (!&untie_user_hash($hashref)) { 2887: &logthis("error: ".($!+0)." untie (GDBM) failed ". 2888: "while attempting newput - early out as key exists"); 2889: } 2890: &Failure($client, "key_exists: ".$key."\n",$userinput); 2891: return 1; 2892: } 2893: } 2894: 2895: foreach my $pair (@pairs) { 2896: my ($key,$value)=split(/=/,$pair); 2897: $hashref->{$key}=$value; 2898: } 2899: 2900: if (&untie_user_hash($hashref)) { 2901: &Reply( $client, "ok\n", $userinput); 2902: } else { 2903: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". 2904: "while attempting put\n", 2905: $userinput); 2906: } 2907: return 1; 2908: } 2909: &register_handler("newput", \&newput_user_profile_entry, 0, 1, 0); 2910: 2911: # 2912: # Increment a profile entry in the user history file. 2913: # The history contains keyword value pairs. In this case, 2914: # The value itself is a pair of numbers. The first, the current value 2915: # the second an increment that this function applies to the current 2916: # value. 2917: # 2918: # Parameters: 2919: # $cmd - The command that got us here. 2920: # $tail - Tail of the command (remaining parameters). 2921: # $client - File descriptor connected to client. 2922: # Returns 2923: # 0 - Requested to exit, caller should shut down. 2924: # 1 - Continue processing. 2925: # 2926: sub increment_user_value_handler { 2927: my ($cmd, $tail, $client) = @_; 2928: 2929: my $userinput = "$cmd:$tail"; 2930: 2931: my ($udom,$uname,$namespace,$what) =split(/:/,$tail); 2932: if ($namespace ne 'roles') { 2933: chomp($what); 2934: my $hashref = &tie_user_hash($udom, $uname, 2935: $namespace, &GDBM_WRCREAT(), 2936: "P",$what); 2937: if ($hashref) { 2938: my @pairs=split(/\&/,$what); 2939: foreach my $pair (@pairs) { 2940: my ($key,$value)=split(/=/,$pair); 2941: $value = &unescape($value); 2942: # We could check that we have a number... 2943: if (! defined($value) || $value eq '') { 2944: $value = 1; 2945: } 2946: $hashref->{$key}+=$value; 2947: if ($namespace eq 'nohist_resourcetracker') { 2948: if ($hashref->{$key} < 0) { 2949: $hashref->{$key} = 0; 2950: } 2951: } 2952: } 2953: if (&untie_user_hash($hashref)) { 2954: &Reply( $client, "ok\n", $userinput); 2955: } else { 2956: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". 2957: "while attempting inc\n", $userinput); 2958: } 2959: } else { 2960: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2961: "while attempting inc\n", $userinput); 2962: } 2963: } else { 2964: &Failure($client, "refused\n", $userinput); 2965: } 2966: 2967: return 1; 2968: } 2969: &register_handler("inc", \&increment_user_value_handler, 0, 1, 0); 2970: 2971: # 2972: # Put a new role for a user. Roles are LonCAPA's packaging of permissions. 2973: # Each 'role' a user has implies a set of permissions. Adding a new role 2974: # for a person grants the permissions packaged with that role 2975: # to that user when the role is selected. 2976: # 2977: # Parameters: 2978: # $cmd - The command string (rolesput). 2979: # $tail - The remainder of the request line. For rolesput this 2980: # consists of a colon separated list that contains: 2981: # The domain and user that is granting the role (logged). 2982: # The domain and user that is getting the role. 2983: # The roles being granted as a set of & separated pairs. 2984: # each pair a key value pair. 2985: # $client - File descriptor connected to the client. 2986: # Returns: 2987: # 0 - If the daemon should exit 2988: # 1 - To continue processing. 2989: # 2990: # 2991: sub roles_put_handler { 2992: my ($cmd, $tail, $client) = @_; 2993: 2994: my $userinput = "$cmd:$tail"; 2995: 2996: my ( $exedom, $exeuser, $udom, $uname, $what) = split(/:/,$tail); 2997: 2998: 2999: my $namespace='roles'; 3000: chomp($what); 3001: my $hashref = &tie_user_hash($udom, $uname, $namespace, 3002: &GDBM_WRCREAT(), "P", 3003: "$exedom:$exeuser:$what"); 3004: # 3005: # Log the attempt to set a role. The {}'s here ensure that the file 3006: # handle is open for the minimal amount of time. Since the flush 3007: # is done on close this improves the chances the log will be an un- 3008: # corrupted ordered thing. 3009: if ($hashref) { 3010: my $pass_entry = &get_auth_type($udom, $uname); 3011: my ($auth_type,$pwd) = split(/:/, $pass_entry); 3012: $auth_type = $auth_type.":"; 3013: my @pairs=split(/\&/,$what); 3014: foreach my $pair (@pairs) { 3015: my ($key,$value)=split(/=/,$pair); 3016: &manage_permissions($key, $udom, $uname, 3017: $auth_type); 3018: $hashref->{$key}=$value; 3019: } 3020: if (&untie_user_hash($hashref)) { 3021: &Reply($client, "ok\n", $userinput); 3022: } else { 3023: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 3024: "while attempting rolesput\n", $userinput); 3025: } 3026: } else { 3027: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 3028: "while attempting rolesput\n", $userinput); 3029: } 3030: return 1; 3031: } 3032: &register_handler("rolesput", \&roles_put_handler, 1,1,0); # Encoded client only. 3033: 3034: # 3035: # Deletes (removes) a role for a user. This is equivalent to removing 3036: # a permissions package associated with the role from the user's profile. 3037: # 3038: # Parameters: 3039: # $cmd - The command (rolesdel) 3040: # $tail - The remainder of the request line. This consists 3041: # of: 3042: # The domain and user requesting the change (logged) 3043: # The domain and user being changed. 3044: # The roles being revoked. These are shipped to us 3045: # as a bunch of & separated role name keywords. 3046: # $client - The file handle open on the client. 3047: # Returns: 3048: # 1 - Continue processing 3049: # 0 - Exit. 3050: # 3051: sub roles_delete_handler { 3052: my ($cmd, $tail, $client) = @_; 3053: 3054: my $userinput = "$cmd:$tail"; 3055: 3056: my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail); 3057: &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom. 3058: "what = ".$what); 3059: my $namespace='roles'; 3060: chomp($what); 3061: my $hashref = &tie_user_hash($udom, $uname, $namespace, 3062: &GDBM_WRCREAT(), "D", 3063: "$exedom:$exeuser:$what"); 3064: 3065: if ($hashref) { 3066: my @rolekeys=split(/\&/,$what); 3067: 3068: foreach my $key (@rolekeys) { 3069: delete $hashref->{$key}; 3070: } 3071: if (&untie_user_hash($hashref)) { 3072: &Reply($client, "ok\n", $userinput); 3073: } else { 3074: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 3075: "while attempting rolesdel\n", $userinput); 3076: } 3077: } else { 3078: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 3079: "while attempting rolesdel\n", $userinput); 3080: } 3081: 3082: return 1; 3083: } 3084: &register_handler("rolesdel", \&roles_delete_handler, 1,1, 0); # Encoded client only 3085: 3086: # Unencrypted get from a user's profile database. See 3087: # GetProfileEntryEncrypted for a version that does end-to-end encryption. 3088: # This function retrieves a keyed item from a specific named database in the 3089: # user's directory. 3090: # 3091: # Parameters: 3092: # $cmd - Command request keyword (get). 3093: # $tail - Tail of the command. This is a colon separated list 3094: # consisting of the domain and username that uniquely 3095: # identifies the profile, 3096: # The 'namespace' which selects the gdbm file to 3097: # do the lookup in, 3098: # & separated list of keys to lookup. Note that 3099: # the values are returned as an & separated list too. 3100: # $client - File descriptor open on the client. 3101: # Returns: 3102: # 1 - Continue processing. 3103: # 0 - Exit. 3104: # 3105: sub get_profile_entry { 3106: my ($cmd, $tail, $client) = @_; 3107: 3108: my $userinput= "$cmd:$tail"; 3109: 3110: my ($udom,$uname,$namespace,$what) = split(/:/,$tail); 3111: chomp($what); 3112: 3113: 3114: my $replystring = read_profile($udom, $uname, $namespace, $what); 3115: my ($first) = split(/:/,$replystring); 3116: if($first ne "error") { 3117: &Reply($client, \$replystring, $userinput); 3118: } else { 3119: &Failure($client, $replystring." while attempting get\n", $userinput); 3120: } 3121: return 1; 3122: 3123: 3124: } 3125: &register_handler("get", \&get_profile_entry, 0,1,0); 3126: 3127: # 3128: # Process the encrypted get request. Note that the request is sent 3129: # in clear, but the reply is encrypted. This is a small covert channel: 3130: # information about the sensitive keys is given to the snooper. Just not 3131: # information about the values of the sensitive key. Hmm if I wanted to 3132: # know these I'd snoop for the egets. Get the profile item names from them 3133: # and then issue a get for them since there's no enforcement of the 3134: # requirement of an encrypted get for particular profile items. If I 3135: # were re-doing this, I'd force the request to be encrypted as well as the 3136: # reply. I'd also just enforce encrypted transactions for all gets since 3137: # that would prevent any covert channel snooping. 3138: # 3139: # Parameters: 3140: # $cmd - Command keyword of request (eget). 3141: # $tail - Tail of the command. See GetProfileEntry # for more information about this. 3142: # $client - File open on the client. 3143: # Returns: 3144: # 1 - Continue processing 3145: # 0 - server should exit. 3146: sub get_profile_entry_encrypted { 3147: my ($cmd, $tail, $client) = @_; 3148: 3149: my $userinput = "$cmd:$tail"; 3150: 3151: my ($udom,$uname,$namespace,$what) = split(/:/,$tail); 3152: chomp($what); 3153: my $qresult = read_profile($udom, $uname, $namespace, $what); 3154: my ($first) = split(/:/, $qresult); 3155: if($first ne "error") { 3156: 3157: if ($cipher) { 3158: my $cmdlength=length($qresult); 3159: $qresult.=" "; 3160: my $encqresult=''; 3161: for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { 3162: $encqresult.= unpack("H16", 3163: $cipher->encrypt(substr($qresult, 3164: $encidx, 3165: 8))); 3166: } 3167: &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput); 3168: } else { 3169: &Failure( $client, "error:no_key\n", $userinput); 3170: } 3171: } else { 3172: &Failure($client, "$qresult while attempting eget\n", $userinput); 3173: 3174: } 3175: 3176: return 1; 3177: } 3178: &register_handler("eget", \&get_profile_entry_encrypted, 0, 1, 0); 3179: 3180: # 3181: # Deletes a key in a user profile database. 3182: # 3183: # Parameters: 3184: # $cmd - Command keyword (del). 3185: # $tail - Command tail. IN this case a colon 3186: # separated list containing: 3187: # The domain and user that identifies uniquely 3188: # the identity of the user. 3189: # The profile namespace (name of the profile 3190: # database file). 3191: # & separated list of keywords to delete. 3192: # $client - File open on client socket. 3193: # Returns: 3194: # 1 - Continue processing 3195: # 0 - Exit server. 3196: # 3197: # 3198: sub delete_profile_entry { 3199: my ($cmd, $tail, $client) = @_; 3200: 3201: my $userinput = "cmd:$tail"; 3202: 3203: my ($udom,$uname,$namespace,$what) = split(/:/,$tail); 3204: chomp($what); 3205: my $hashref = &tie_user_hash($udom, $uname, $namespace, 3206: &GDBM_WRCREAT(), 3207: "D",$what); 3208: if ($hashref) { 3209: my @keys=split(/\&/,$what); 3210: foreach my $key (@keys) { 3211: delete($hashref->{$key}); 3212: } 3213: if (&untie_user_hash($hashref)) { 3214: &Reply($client, "ok\n", $userinput); 3215: } else { 3216: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 3217: "while attempting del\n", $userinput); 3218: } 3219: } else { 3220: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 3221: "while attempting del\n", $userinput); 3222: } 3223: return 1; 3224: } 3225: &register_handler("del", \&delete_profile_entry, 0, 1, 0); 3226: 3227: # 3228: # List the set of keys that are defined in a profile database file. 3229: # A successful reply from this will contain an & separated list of 3230: # the keys. 3231: # Parameters: 3232: # $cmd - Command request (keys). 3233: # $tail - Remainder of the request, a colon separated 3234: # list containing domain/user that identifies the 3235: # user being queried, and the database namespace 3236: # (database filename essentially). 3237: # $client - File open on the client. 3238: # Returns: 3239: # 1 - Continue processing. 3240: # 0 - Exit the server. 3241: # 3242: sub get_profile_keys { 3243: my ($cmd, $tail, $client) = @_; 3244: 3245: my $userinput = "$cmd:$tail"; 3246: 3247: my ($udom,$uname,$namespace)=split(/:/,$tail); 3248: my $qresult=''; 3249: my $hashref = &tie_user_hash($udom, $uname, $namespace, 3250: &GDBM_READER()); 3251: if ($hashref) { 3252: foreach my $key (keys %$hashref) { 3253: $qresult.="$key&"; 3254: } 3255: if (&untie_user_hash($hashref)) { 3256: $qresult=~s/\&$//; 3257: &Reply($client, \$qresult, $userinput); 3258: } else { 3259: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 3260: "while attempting keys\n", $userinput); 3261: } 3262: } else { 3263: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 3264: "while attempting keys\n", $userinput); 3265: } 3266: 3267: return 1; 3268: } 3269: &register_handler("keys", \&get_profile_keys, 0, 1, 0); 3270: 3271: # 3272: # Dump the contents of a user profile database. 3273: # Note that this constitutes a very large covert channel too since 3274: # the dump will return sensitive information that is not encrypted. 3275: # The naive security assumption is that the session negotiation ensures 3276: # our client is trusted and I don't believe that's assured at present. 3277: # Sure want badly to go to ssl or tls. Of course if my peer isn't really 3278: # a LonCAPA node they could have negotiated an encryption key too so >sigh<. 3279: # 3280: # Parameters: 3281: # $cmd - The command request keyword (currentdump). 3282: # $tail - Remainder of the request, consisting of a colon 3283: # separated list that has the domain/username and 3284: # the namespace to dump (database file). 3285: # $client - file open on the remote client. 3286: # Returns: 3287: # 1 - Continue processing. 3288: # 0 - Exit the server. 3289: # 3290: sub dump_profile_database { 3291: my ($cmd, $tail, $client) = @_; 3292: 3293: my $res = LONCAPA::Lond::dump_profile_database($tail); 3294: 3295: if ($res =~ /^error:/) { 3296: Failure($client, \$res, "$cmd:$tail"); 3297: } else { 3298: Reply($client, \$res, "$cmd:$tail"); 3299: } 3300: 3301: return 1; 3302: 3303: #TODO remove 3304: my $userinput = "$cmd:$tail"; 3305: 3306: my ($udom,$uname,$namespace) = split(/:/,$tail); 3307: my $hashref = &tie_user_hash($udom, $uname, $namespace, 3308: &GDBM_READER()); 3309: if ($hashref) { 3310: # Structure of %data: 3311: # $data{$symb}->{$parameter}=$value; 3312: # $data{$symb}->{'v.'.$parameter}=$version; 3313: # since $parameter will be unescaped, we do not 3314: # have to worry about silly parameter names... 3315: 3316: my $qresult=''; 3317: my %data = (); # A hash of anonymous hashes.. 3318: while (my ($key,$value) = each(%$hashref)) { 3319: my ($v,$symb,$param) = split(/:/,$key); 3320: next if ($v eq 'version' || $symb eq 'keys'); 3321: next if (exists($data{$symb}) && 3322: exists($data{$symb}->{$param}) && 3323: $data{$symb}->{'v.'.$param} > $v); 3324: $data{$symb}->{$param}=$value; 3325: $data{$symb}->{'v.'.$param}=$v; 3326: } 3327: if (&untie_user_hash($hashref)) { 3328: while (my ($symb,$param_hash) = each(%data)) { 3329: while(my ($param,$value) = each (%$param_hash)){ 3330: next if ($param =~ /^v\./); # Ignore versions... 3331: # 3332: # Just dump the symb=value pairs separated by & 3333: # 3334: $qresult.=$symb.':'.$param.'='.$value.'&'; 3335: } 3336: } 3337: chop($qresult); 3338: &Reply($client , \$qresult, $userinput); 3339: } else { 3340: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 3341: "while attempting currentdump\n", $userinput); 3342: } 3343: } else { 3344: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 3345: "while attempting currentdump\n", $userinput); 3346: } 3347: 3348: return 1; 3349: } 3350: &register_handler("currentdump", \&dump_profile_database, 0, 1, 0); 3351: 3352: # 3353: # Dump a profile database with an optional regular expression 3354: # to match against the keys. In this dump, no effort is made 3355: # to separate symb from version information. Presumably the 3356: # databases that are dumped by this command are of a different 3357: # structure. Need to look at this and improve the documentation of 3358: # both this and the currentdump handler. 3359: # Parameters: 3360: # $cmd - The command keyword. 3361: # $tail - All of the characters after the $cmd: 3362: # These are expected to be a colon 3363: # separated list containing: 3364: # domain/user - identifying the user. 3365: # namespace - identifying the database. 3366: # regexp - optional regular expression 3367: # that is matched against 3368: # database keywords to do 3369: # selective dumps. 3370: # range - optional range of entries 3371: # e.g., 10-20 would return the 3372: # 10th to 19th items, etc. 3373: # $client - Channel open on the client. 3374: # Returns: 3375: # 1 - Continue processing. 3376: # Side effects: 3377: # response is written to $client. 3378: # 3379: sub dump_with_regexp { 3380: my ($cmd, $tail, $client) = @_; 3381: 3382: my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion); 3383: 3384: if ($res =~ /^error:/) { 3385: Failure($client, \$res, "$cmd:$tail"); 3386: } else { 3387: Reply($client, \$res, "$cmd:$tail"); 3388: } 3389: 3390: return 1; 3391: } 3392: &register_handler("dump", \&dump_with_regexp, 0, 1, 0); 3393: 3394: # Store a set of key=value pairs associated with a versioned name. 3395: # 3396: # Parameters: 3397: # $cmd - Request command keyword. 3398: # $tail - Tail of the request. This is a colon 3399: # separated list containing: 3400: # domain/user - User and authentication domain. 3401: # namespace - Name of the database being modified 3402: # rid - Resource keyword to modify. 3403: # what - new value associated with rid. 3404: # laststore - (optional) version=timestamp 3405: # for most recent transaction for rid 3406: # in namespace, when cstore was called 3407: # 3408: # $client - Socket open on the client. 3409: # 3410: # 3411: # Returns: 3412: # 1 (keep on processing). 3413: # Side-Effects: 3414: # Writes to the client 3415: # Successful storage will cause either 'ok', or, if $laststore was included 3416: # in the tail of the request, and the version number for the last transaction 3417: # is larger than the version in $laststore, delay:$numtrans , where $numtrans 3418: # is the number of store evevnts recorded for rid in namespace since 3419: # lonnet::store() was called by the client. 3420: # 3421: sub store_handler { 3422: my ($cmd, $tail, $client) = @_; 3423: 3424: my $userinput = "$cmd:$tail"; 3425: chomp($tail); 3426: my ($udom,$uname,$namespace,$rid,$what,$laststore) =split(/:/,$tail); 3427: if ($namespace ne 'roles') { 3428: 3429: my @pairs=split(/\&/,$what); 3430: my $hashref = &tie_user_hash($udom, $uname, $namespace, 3431: &GDBM_WRCREAT(), "S", 3432: "$rid:$what"); 3433: if ($hashref) { 3434: my $now = time; 3435: my $numtrans; 3436: if ($laststore) { 3437: my ($previousversion,$previoustime) = split(/\=/,$laststore); 3438: my ($lastversion,$lasttime) = (0,0); 3439: $lastversion = $hashref->{"version:$rid"}; 3440: if ($lastversion) { 3441: $lasttime = $hashref->{"$lastversion:$rid:timestamp"}; 3442: } 3443: if (($previousversion) && ($previousversion !~ /\D/)) { 3444: if (($lastversion > $previousversion) && ($lasttime >= $previoustime)) { 3445: $numtrans = $lastversion - $previousversion; 3446: } 3447: } elsif ($lastversion) { 3448: $numtrans = $lastversion; 3449: } 3450: if ($numtrans) { 3451: $numtrans =~ s/D//g; 3452: } 3453: } 3454: $hashref->{"version:$rid"}++; 3455: my $version=$hashref->{"version:$rid"}; 3456: my $allkeys=''; 3457: foreach my $pair (@pairs) { 3458: my ($key,$value)=split(/=/,$pair); 3459: $allkeys.=$key.':'; 3460: $hashref->{"$version:$rid:$key"}=$value; 3461: } 3462: $hashref->{"$version:$rid:timestamp"}=$now; 3463: $allkeys.='timestamp'; 3464: $hashref->{"$version:keys:$rid"}=$allkeys; 3465: if (&untie_user_hash($hashref)) { 3466: my $msg = 'ok'; 3467: if ($numtrans) { 3468: $msg = 'delay:'.$numtrans; 3469: } 3470: &Reply($client, "$msg\n", $userinput); 3471: } else { 3472: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 3473: "while attempting store\n", $userinput); 3474: } 3475: } else { 3476: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 3477: "while attempting store\n", $userinput); 3478: } 3479: } else { 3480: &Failure($client, "refused\n", $userinput); 3481: } 3482: 3483: return 1; 3484: } 3485: &register_handler("store", \&store_handler, 0, 1, 0); 3486: 3487: # Modify a set of key=value pairs associated with a versioned name. 3488: # 3489: # Parameters: 3490: # $cmd - Request command keyword. 3491: # $tail - Tail of the request. This is a colon 3492: # separated list containing: 3493: # domain/user - User and authentication domain. 3494: # namespace - Name of the database being modified 3495: # rid - Resource keyword to modify. 3496: # v - Version item to modify 3497: # what - new value associated with rid. 3498: # 3499: # $client - Socket open on the client. 3500: # 3501: # 3502: # Returns: 3503: # 1 (keep on processing). 3504: # Side-Effects: 3505: # Writes to the client 3506: sub putstore_handler { 3507: my ($cmd, $tail, $client) = @_; 3508: 3509: my $userinput = "$cmd:$tail"; 3510: 3511: my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail); 3512: if ($namespace ne 'roles') { 3513: 3514: chomp($what); 3515: my $hashref = &tie_user_hash($udom, $uname, $namespace, 3516: &GDBM_WRCREAT(), "M", 3517: "$rid:$v:$what"); 3518: if ($hashref) { 3519: my $now = time; 3520: my %data = &hash_extract($what); 3521: my @allkeys; 3522: while (my($key,$value) = each(%data)) { 3523: push(@allkeys,$key); 3524: $hashref->{"$v:$rid:$key"} = $value; 3525: } 3526: my $allkeys = join(':',@allkeys); 3527: $hashref->{"$v:keys:$rid"}=$allkeys; 3528: 3529: if (&untie_user_hash($hashref)) { 3530: &Reply($client, "ok\n", $userinput); 3531: } else { 3532: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 3533: "while attempting store\n", $userinput); 3534: } 3535: } else { 3536: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 3537: "while attempting store\n", $userinput); 3538: } 3539: } else { 3540: &Failure($client, "refused\n", $userinput); 3541: } 3542: 3543: return 1; 3544: } 3545: &register_handler("putstore", \&putstore_handler, 0, 1, 0); 3546: 3547: sub hash_extract { 3548: my ($str)=@_; 3549: my %hash; 3550: foreach my $pair (split(/\&/,$str)) { 3551: my ($key,$value)=split(/=/,$pair); 3552: $hash{$key}=$value; 3553: } 3554: return (%hash); 3555: } 3556: sub hash_to_str { 3557: my ($hash_ref)=@_; 3558: my $str; 3559: foreach my $key (keys(%$hash_ref)) { 3560: $str.=$key.'='.$hash_ref->{$key}.'&'; 3561: } 3562: $str=~s/\&$//; 3563: return $str; 3564: } 3565: 3566: # 3567: # Dump out all versions of a resource that has key=value pairs associated 3568: # with it for each version. These resources are built up via the store 3569: # command. 3570: # 3571: # Parameters: 3572: # $cmd - Command keyword. 3573: # $tail - Remainder of the request which consists of: 3574: # domain/user - User and auth. domain. 3575: # namespace - name of resource database. 3576: # rid - Resource id. 3577: # $client - socket open on the client. 3578: # 3579: # Returns: 3580: # 1 indicating the caller should not yet exit. 3581: # Side-effects: 3582: # Writes a reply to the client. 3583: # The reply is a string of the following shape: 3584: # version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2... 3585: # Where the 1 above represents version 1. 3586: # this continues for all pairs of keys in all versions. 3587: # 3588: # 3589: # 3590: # 3591: sub restore_handler { 3592: my ($cmd, $tail, $client) = @_; 3593: 3594: my $userinput = "$cmd:$tail"; # Only used for logging purposes. 3595: my ($udom,$uname,$namespace,$rid) = split(/:/,$tail); 3596: $namespace=~s/\//\_/g; 3597: $namespace = &LONCAPA::clean_username($namespace); 3598: 3599: chomp($rid); 3600: my $qresult=''; 3601: my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); 3602: if ($hashref) { 3603: my $version=$hashref->{"version:$rid"}; 3604: $qresult.="version=$version&"; 3605: my $scope; 3606: for ($scope=1;$scope<=$version;$scope++) { 3607: my $vkeys=$hashref->{"$scope:keys:$rid"}; 3608: my @keys=split(/:/,$vkeys); 3609: my $key; 3610: $qresult.="$scope:keys=$vkeys&"; 3611: foreach $key (@keys) { 3612: $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&"; 3613: } 3614: } 3615: if (&untie_user_hash($hashref)) { 3616: $qresult=~s/\&$//; 3617: &Reply( $client, \$qresult, $userinput); 3618: } else { 3619: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 3620: "while attempting restore\n", $userinput); 3621: } 3622: } else { 3623: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 3624: "while attempting restore\n", $userinput); 3625: } 3626: 3627: return 1; 3628: 3629: 3630: } 3631: &register_handler("restore", \&restore_handler, 0,1,0); 3632: 3633: # 3634: # Add a chat message to a synchronous discussion board. 3635: # 3636: # Parameters: 3637: # $cmd - Request keyword. 3638: # $tail - Tail of the command. A colon separated list 3639: # containing: 3640: # cdom - Domain on which the chat board lives 3641: # cnum - Course containing the chat board. 3642: # newpost - Body of the posting. 3643: # group - Optional group, if chat board is only 3644: # accessible in a group within the course 3645: # $client - Socket open on the client. 3646: # Returns: 3647: # 1 - Indicating caller should keep on processing. 3648: # 3649: # Side-effects: 3650: # writes a reply to the client. 3651: # 3652: # 3653: sub send_chat_handler { 3654: my ($cmd, $tail, $client) = @_; 3655: 3656: 3657: my $userinput = "$cmd:$tail"; 3658: 3659: my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail); 3660: &chat_add($cdom,$cnum,$newpost,$group); 3661: &Reply($client, "ok\n", $userinput); 3662: 3663: return 1; 3664: } 3665: &register_handler("chatsend", \&send_chat_handler, 0, 1, 0); 3666: 3667: # 3668: # Retrieve the set of chat messages from a discussion board. 3669: # 3670: # Parameters: 3671: # $cmd - Command keyword that initiated the request. 3672: # $tail - Remainder of the request after the command 3673: # keyword. In this case a colon separated list of 3674: # chat domain - Which discussion board. 3675: # chat id - Discussion thread(?) 3676: # domain/user - Authentication domain and username 3677: # of the requesting person. 3678: # group - Optional course group containing 3679: # the board. 3680: # $client - Socket open on the client program. 3681: # Returns: 3682: # 1 - continue processing 3683: # Side effects: 3684: # Response is written to the client. 3685: # 3686: sub retrieve_chat_handler { 3687: my ($cmd, $tail, $client) = @_; 3688: 3689: 3690: my $userinput = "$cmd:$tail"; 3691: 3692: my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail); 3693: my $reply=''; 3694: foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) { 3695: $reply.=&escape($_).':'; 3696: } 3697: $reply=~s/\:$//; 3698: &Reply($client, \$reply, $userinput); 3699: 3700: 3701: return 1; 3702: } 3703: &register_handler("chatretr", \&retrieve_chat_handler, 0, 1, 0); 3704: 3705: # 3706: # Initiate a query of an sql database. SQL query repsonses get put in 3707: # a file for later retrieval. This prevents sql query results from 3708: # bottlenecking the system. Note that with loncnew, perhaps this is 3709: # less of an issue since multiple outstanding requests can be concurrently 3710: # serviced. 3711: # 3712: # Parameters: 3713: # $cmd - COmmand keyword that initiated the request. 3714: # $tail - Remainder of the command after the keyword. 3715: # For this function, this consists of a query and 3716: # 3 arguments that are self-documentingly labelled 3717: # in the original arg1, arg2, arg3. 3718: # $client - Socket open on the client. 3719: # Return: 3720: # 1 - Indicating processing should continue. 3721: # Side-effects: 3722: # a reply is written to $client. 3723: # 3724: sub send_query_handler { 3725: my ($cmd, $tail, $client) = @_; 3726: 3727: 3728: my $userinput = "$cmd:$tail"; 3729: 3730: my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail); 3731: $query=~s/\n*$//g; 3732: &Reply($client, "". &sql_reply("$clientname\&$query". 3733: "\&$arg1"."\&$arg2"."\&$arg3")."\n", 3734: $userinput); 3735: 3736: return 1; 3737: } 3738: &register_handler("querysend", \&send_query_handler, 0, 1, 0); 3739: 3740: # 3741: # Add a reply to an sql query. SQL queries are done asyncrhonously. 3742: # The query is submitted via a "querysend" transaction. 3743: # There it is passed on to the lonsql daemon, queued and issued to 3744: # mysql. 3745: # This transaction is invoked when the sql transaction is complete 3746: # it stores the query results in flie and indicates query completion. 3747: # presumably local software then fetches this response... I'm guessing 3748: # the sequence is: lonc does a querysend, we ask lonsql to do it. 3749: # lonsql on completion of the query interacts with the lond of our 3750: # client to do a query reply storing two files: 3751: # - id - The results of the query. 3752: # - id.end - Indicating the transaction completed. 3753: # NOTE: id is a unique id assigned to the query and querysend time. 3754: # Parameters: 3755: # $cmd - Command keyword that initiated this request. 3756: # $tail - Remainder of the tail. In this case that's a colon 3757: # separated list containing the query Id and the 3758: # results of the query. 3759: # $client - Socket open on the client. 3760: # Return: 3761: # 1 - Indicating that we should continue processing. 3762: # Side effects: 3763: # ok written to the client. 3764: # 3765: sub reply_query_handler { 3766: my ($cmd, $tail, $client) = @_; 3767: 3768: 3769: my $userinput = "$cmd:$tail"; 3770: 3771: my ($id,$reply)=split(/:/,$tail); 3772: my $store; 3773: my $execdir=$perlvar{'lonDaemons'}; 3774: if ($store=IO::File->new(">$execdir/tmp/$id")) { 3775: $reply=~s/\&/\n/g; 3776: print $store $reply; 3777: close $store; 3778: my $store2=IO::File->new(">$execdir/tmp/$id.end"); 3779: print $store2 "done\n"; 3780: close $store2; 3781: &Reply($client, "ok\n", $userinput); 3782: } else { 3783: &Failure($client, "error: ".($!+0) 3784: ." IO::File->new Failed ". 3785: "while attempting queryreply\n", $userinput); 3786: } 3787: 3788: 3789: return 1; 3790: } 3791: &register_handler("queryreply", \&reply_query_handler, 0, 1, 0); 3792: 3793: # 3794: # Process the courseidput request. Not quite sure what this means 3795: # at the system level sense. It appears a gdbm file in the 3796: # /home/httpd/lonUsers/$domain/nohist_courseids is tied and 3797: # a set of entries made in that database. 3798: # 3799: # Parameters: 3800: # $cmd - The command keyword that initiated this request. 3801: # $tail - Tail of the command. In this case consists of a colon 3802: # separated list contaning the domain to apply this to and 3803: # an ampersand separated list of keyword=value pairs. 3804: # Each value is a colon separated list that includes: 3805: # description, institutional code and course owner. 3806: # For backward compatibility with versions included 3807: # in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional 3808: # code and/or course owner are preserved from the existing 3809: # record when writing a new record in response to 1.1 or 3810: # 1.2 implementations of lonnet::flushcourselogs(). 3811: # 3812: # $client - Socket open on the client. 3813: # Returns: 3814: # 1 - indicating that processing should continue 3815: # 3816: # Side effects: 3817: # reply is written to the client. 3818: # 3819: sub put_course_id_handler { 3820: my ($cmd, $tail, $client) = @_; 3821: 3822: 3823: my $userinput = "$cmd:$tail"; 3824: 3825: my ($udom, $what) = split(/:/, $tail,2); 3826: chomp($what); 3827: my $now=time; 3828: my @pairs=split(/\&/,$what); 3829: 3830: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); 3831: if ($hashref) { 3832: foreach my $pair (@pairs) { 3833: my ($key,$courseinfo) = split(/=/,$pair,2); 3834: $courseinfo =~ s/=/:/g; 3835: if (defined($hashref->{$key})) { 3836: my $value = &Apache::lonnet::thaw_unescape($hashref->{$key}); 3837: if (ref($value) eq 'HASH') { 3838: my @items = ('description','inst_code','owner','type'); 3839: my @new_items = split(/:/,$courseinfo,-1); 3840: my %storehash; 3841: for (my $i=0; $i<@new_items; $i++) { 3842: $storehash{$items[$i]} = &unescape($new_items[$i]); 3843: } 3844: $hashref->{$key} = 3845: &Apache::lonnet::freeze_escape(\%storehash); 3846: my $unesc_key = &unescape($key); 3847: $hashref->{&escape('lasttime:'.$unesc_key)} = $now; 3848: next; 3849: } 3850: } 3851: my @current_items = split(/:/,$hashref->{$key},-1); 3852: shift(@current_items); # remove description 3853: pop(@current_items); # remove last access 3854: my $numcurrent = scalar(@current_items); 3855: if ($numcurrent > 3) { 3856: $numcurrent = 3; 3857: } 3858: my @new_items = split(/:/,$courseinfo,-1); 3859: my $numnew = scalar(@new_items); 3860: if ($numcurrent > 0) { 3861: if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 3862: for (my $j=$numcurrent-$numnew; $j>=0; $j--) { 3863: $courseinfo .= ':'.$current_items[$numcurrent-$j-1]; 3864: } 3865: } 3866: } 3867: $hashref->{$key}=$courseinfo.':'.$now; 3868: } 3869: if (&untie_domain_hash($hashref)) { 3870: &Reply( $client, "ok\n", $userinput); 3871: } else { 3872: &Failure($client, "error: ".($!+0) 3873: ." untie(GDBM) Failed ". 3874: "while attempting courseidput\n", $userinput); 3875: } 3876: } else { 3877: &Failure($client, "error: ".($!+0) 3878: ." tie(GDBM) Failed ". 3879: "while attempting courseidput\n", $userinput); 3880: } 3881: 3882: return 1; 3883: } 3884: &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0); 3885: 3886: sub put_course_id_hash_handler { 3887: my ($cmd, $tail, $client) = @_; 3888: my $userinput = "$cmd:$tail"; 3889: my ($udom,$mode,$what) = split(/:/, $tail,3); 3890: chomp($what); 3891: my $now=time; 3892: my @pairs=split(/\&/,$what); 3893: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); 3894: if ($hashref) { 3895: foreach my $pair (@pairs) { 3896: my ($key,$value)=split(/=/,$pair); 3897: my $unesc_key = &unescape($key); 3898: if ($mode ne 'timeonly') { 3899: if (!defined($hashref->{&escape('lasttime:'.$unesc_key)})) { 3900: my $curritems = &Apache::lonnet::thaw_unescape($key); 3901: if (ref($curritems) ne 'HASH') { 3902: my @current_items = split(/:/,$hashref->{$key},-1); 3903: my $lasttime = pop(@current_items); 3904: $hashref->{&escape('lasttime:'.$unesc_key)} = $lasttime; 3905: } else { 3906: $hashref->{&escape('lasttime:'.$unesc_key)} = ''; 3907: } 3908: } 3909: $hashref->{$key} = $value; 3910: } 3911: if ($mode ne 'notime') { 3912: $hashref->{&escape('lasttime:'.$unesc_key)} = $now; 3913: } 3914: } 3915: if (&untie_domain_hash($hashref)) { 3916: &Reply($client, "ok\n", $userinput); 3917: } else { 3918: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 3919: "while attempting courseidputhash\n", $userinput); 3920: } 3921: } else { 3922: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 3923: "while attempting courseidputhash\n", $userinput); 3924: } 3925: return 1; 3926: } 3927: &register_handler("courseidputhash", \&put_course_id_hash_handler, 0, 1, 0); 3928: 3929: # Retrieves the value of a course id resource keyword pattern 3930: # defined since a starting date. Both the starting date and the 3931: # keyword pattern are optional. If the starting date is not supplied it 3932: # is treated as the beginning of time. If the pattern is not found, 3933: # it is treatred as "." matching everything. 3934: # 3935: # Parameters: 3936: # $cmd - Command keyword that resulted in us being dispatched. 3937: # $tail - The remainder of the command that, in this case, consists 3938: # of a colon separated list of: 3939: # domain - The domain in which the course database is 3940: # defined. 3941: # since - Optional parameter describing the minimum 3942: # time of definition(?) of the resources that 3943: # will match the dump. 3944: # description - regular expression that is used to filter 3945: # the dump. Only keywords matching this regexp 3946: # will be used. 3947: # institutional code - optional supplied code to filter 3948: # the dump. Only courses with an institutional code 3949: # that match the supplied code will be returned. 3950: # owner - optional supplied username and domain of owner to 3951: # filter the dump. Only courses for which the course 3952: # owner matches the supplied username and/or domain 3953: # will be returned. Pre-2.2.0 legacy entries from 3954: # nohist_courseiddump will only contain usernames. 3955: # type - optional parameter for selection 3956: # regexp_ok - if 1 or -1 allow the supplied institutional code 3957: # filter to behave as a regular expression: 3958: # 1 will not exclude the course if the instcode matches the RE 3959: # -1 will exclude the course if the instcode matches the RE 3960: # rtn_as_hash - whether to return the information available for 3961: # each matched item as a frozen hash of all 3962: # key, value pairs in the item's hash, or as a 3963: # colon-separated list of (in order) description, 3964: # institutional code, and course owner. 3965: # selfenrollonly - filter by courses allowing self-enrollment 3966: # now or in the future (selfenrollonly = 1). 3967: # catfilter - filter by course category, assigned to a course 3968: # using manually defined categories (i.e., not 3969: # self-cataloging based on on institutional code). 3970: # showhidden - include course in results even if course 3971: # was set to be excluded from course catalog (DC only). 3972: # caller - if set to 'coursecatalog', courses set to be hidden 3973: # from course catalog will be excluded from results (unless 3974: # overridden by "showhidden". 3975: # cloner - escaped username:domain of course cloner (if picking course to 3976: # clone). 3977: # cc_clone_list - escaped comma separated list of courses for which 3978: # course cloner has active CC role (and so can clone 3979: # automatically). 3980: # cloneonly - filter by courses for which cloner has rights to clone. 3981: # createdbefore - include courses for which creation date preceeded this date. 3982: # createdafter - include courses for which creation date followed this date. 3983: # creationcontext - include courses created in specified context 3984: # 3985: # domcloner - flag to indicate if user can create CCs in course's domain. 3986: # If so, ability to clone course is automatic. 3987: # hasuniquecode - filter by courses for which a six character unique code has 3988: # been set. 3989: # 3990: # $client - The socket open on the client. 3991: # Returns: 3992: # 1 - Continue processing. 3993: # Side Effects: 3994: # a reply is written to $client. 3995: sub dump_course_id_handler { 3996: my ($cmd, $tail, $client) = @_; 3997: 3998: my $res = LONCAPA::Lond::dump_course_id_handler($tail); 3999: if ($res =~ /^error:/) { 4000: Failure($client, \$res, "$cmd:$tail"); 4001: } else { 4002: Reply($client, \$res, "$cmd:$tail"); 4003: } 4004: 4005: return 1; 4006: 4007: #TODO remove 4008: my $userinput = "$cmd:$tail"; 4009: 4010: my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter, 4011: $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden, 4012: $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter, 4013: $creationcontext,$domcloner,$hasuniquecode) =split(/:/,$tail); 4014: my $now = time; 4015: my ($cloneruname,$clonerudom,%cc_clone); 4016: if (defined($description)) { 4017: $description=&unescape($description); 4018: } else { 4019: $description='.'; 4020: } 4021: if (defined($instcodefilter)) { 4022: $instcodefilter=&unescape($instcodefilter); 4023: } else { 4024: $instcodefilter='.'; 4025: } 4026: my ($ownerunamefilter,$ownerdomfilter); 4027: if (defined($ownerfilter)) { 4028: $ownerfilter=&unescape($ownerfilter); 4029: if ($ownerfilter ne '.' && defined($ownerfilter)) { 4030: if ($ownerfilter =~ /^([^:]*):([^:]*)$/) { 4031: $ownerunamefilter = $1; 4032: $ownerdomfilter = $2; 4033: } else { 4034: $ownerunamefilter = $ownerfilter; 4035: $ownerdomfilter = ''; 4036: } 4037: } 4038: } else { 4039: $ownerfilter='.'; 4040: } 4041: 4042: if (defined($coursefilter)) { 4043: $coursefilter=&unescape($coursefilter); 4044: } else { 4045: $coursefilter='.'; 4046: } 4047: if (defined($typefilter)) { 4048: $typefilter=&unescape($typefilter); 4049: } else { 4050: $typefilter='.'; 4051: } 4052: if (defined($regexp_ok)) { 4053: $regexp_ok=&unescape($regexp_ok); 4054: } 4055: if (defined($catfilter)) { 4056: $catfilter=&unescape($catfilter); 4057: } 4058: if (defined($cloner)) { 4059: $cloner = &unescape($cloner); 4060: ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/); 4061: } 4062: if (defined($cc_clone_list)) { 4063: $cc_clone_list = &unescape($cc_clone_list); 4064: my @cc_cloners = split('&',$cc_clone_list); 4065: foreach my $cid (@cc_cloners) { 4066: my ($clonedom,$clonenum) = split(':',$cid); 4067: next if ($clonedom ne $udom); 4068: $cc_clone{$clonedom.'_'.$clonenum} = 1; 4069: } 4070: } 4071: if ($createdbefore ne '') { 4072: $createdbefore = &unescape($createdbefore); 4073: } else { 4074: $createdbefore = 0; 4075: } 4076: if ($createdafter ne '') { 4077: $createdafter = &unescape($createdafter); 4078: } else { 4079: $createdafter = 0; 4080: } 4081: if ($creationcontext ne '') { 4082: $creationcontext = &unescape($creationcontext); 4083: } else { 4084: $creationcontext = '.'; 4085: } 4086: unless ($hasuniquecode) { 4087: $hasuniquecode = '.'; 4088: } 4089: my $unpack = 1; 4090: if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && 4091: $typefilter eq '.') { 4092: $unpack = 0; 4093: } 4094: if (!defined($since)) { $since=0; } 4095: my $qresult=''; 4096: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); 4097: if ($hashref) { 4098: while (my ($key,$value) = each(%$hashref)) { 4099: my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val, 4100: %unesc_val,$selfenroll_end,$selfenroll_types,$created, 4101: $context); 4102: $unesc_key = &unescape($key); 4103: if ($unesc_key =~ /^lasttime:/) { 4104: next; 4105: } else { 4106: $lasttime_key = &escape('lasttime:'.$unesc_key); 4107: } 4108: if ($hashref->{$lasttime_key} ne '') { 4109: $lasttime = $hashref->{$lasttime_key}; 4110: next if ($lasttime<$since); 4111: } 4112: my ($canclone,$valchange); 4113: my $items = &Apache::lonnet::thaw_unescape($value); 4114: if (ref($items) eq 'HASH') { 4115: if ($hashref->{$lasttime_key} eq '') { 4116: next if ($since > 1); 4117: } 4118: $is_hash = 1; 4119: if ($domcloner) { 4120: $canclone = 1; 4121: } elsif (defined($clonerudom)) { 4122: if ($items->{'cloners'}) { 4123: my @cloneable = split(',',$items->{'cloners'}); 4124: if (@cloneable) { 4125: if (grep(/^\*$/,@cloneable)) { 4126: $canclone = 1; 4127: } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) { 4128: $canclone = 1; 4129: } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) { 4130: $canclone = 1; 4131: } 4132: } 4133: unless ($canclone) { 4134: if ($cloneruname ne '' && $clonerudom ne '') { 4135: if ($cc_clone{$unesc_key}) { 4136: $canclone = 1; 4137: $items->{'cloners'} .= ','.$cloneruname.':'. 4138: $clonerudom; 4139: $valchange = 1; 4140: } 4141: } 4142: } 4143: } elsif (defined($cloneruname)) { 4144: if ($cc_clone{$unesc_key}) { 4145: $canclone = 1; 4146: $items->{'cloners'} = $cloneruname.':'.$clonerudom; 4147: $valchange = 1; 4148: } 4149: unless ($canclone) { 4150: if ($items->{'owner'} =~ /:/) { 4151: if ($items->{'owner'} eq $cloner) { 4152: $canclone = 1; 4153: } 4154: } elsif ($cloner eq $items->{'owner'}.':'.$udom) { 4155: $canclone = 1; 4156: } 4157: if ($canclone) { 4158: $items->{'cloners'} = $cloneruname.':'.$clonerudom; 4159: $valchange = 1; 4160: } 4161: } 4162: } 4163: } 4164: if ($unpack || !$rtn_as_hash) { 4165: $unesc_val{'descr'} = $items->{'description'}; 4166: $unesc_val{'inst_code'} = $items->{'inst_code'}; 4167: $unesc_val{'owner'} = $items->{'owner'}; 4168: $unesc_val{'type'} = $items->{'type'}; 4169: $unesc_val{'cloners'} = $items->{'cloners'}; 4170: $unesc_val{'created'} = $items->{'created'}; 4171: $unesc_val{'context'} = $items->{'context'}; 4172: } 4173: $selfenroll_types = $items->{'selfenroll_types'}; 4174: $selfenroll_end = $items->{'selfenroll_end_date'}; 4175: $created = $items->{'created'}; 4176: $context = $items->{'context'}; 4177: if ($hasuniquecode ne '.') { 4178: next unless ($items->{'uniquecode'}); 4179: } 4180: if ($selfenrollonly) { 4181: next if (!$selfenroll_types); 4182: if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) { 4183: next; 4184: } 4185: } 4186: if ($creationcontext ne '.') { 4187: next if (($context ne '') && ($context ne $creationcontext)); 4188: } 4189: if ($createdbefore > 0) { 4190: next if (($created eq '') || ($created > $createdbefore)); 4191: } 4192: if ($createdafter > 0) { 4193: next if (($created eq '') || ($created <= $createdafter)); 4194: } 4195: if ($catfilter ne '') { 4196: next if ($items->{'categories'} eq ''); 4197: my @categories = split('&',$items->{'categories'}); 4198: next if (@categories == 0); 4199: my @subcats = split('&',$catfilter); 4200: my $matchcat = 0; 4201: foreach my $cat (@categories) { 4202: if (grep(/^\Q$cat\E$/,@subcats)) { 4203: $matchcat = 1; 4204: last; 4205: } 4206: } 4207: next if (!$matchcat); 4208: } 4209: if ($caller eq 'coursecatalog') { 4210: if ($items->{'hidefromcat'} eq 'yes') { 4211: next if !$showhidden; 4212: } 4213: } 4214: } else { 4215: next if ($catfilter ne ''); 4216: next if ($selfenrollonly); 4217: next if ($createdbefore || $createdafter); 4218: next if ($creationcontext ne '.'); 4219: if ((defined($clonerudom)) && (defined($cloneruname))) { 4220: if ($cc_clone{$unesc_key}) { 4221: $canclone = 1; 4222: $val{'cloners'} = &escape($cloneruname.':'.$clonerudom); 4223: } 4224: } 4225: $is_hash = 0; 4226: my @courseitems = split(/:/,$value); 4227: $lasttime = pop(@courseitems); 4228: if ($hashref->{$lasttime_key} eq '') { 4229: next if ($lasttime<$since); 4230: } 4231: ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems; 4232: } 4233: if ($cloneonly) { 4234: next unless ($canclone); 4235: } 4236: my $match = 1; 4237: if ($description ne '.') { 4238: if (!$is_hash) { 4239: $unesc_val{'descr'} = &unescape($val{'descr'}); 4240: } 4241: if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) { 4242: $match = 0; 4243: } 4244: } 4245: if ($instcodefilter ne '.') { 4246: if (!$is_hash) { 4247: $unesc_val{'inst_code'} = &unescape($val{'inst_code'}); 4248: } 4249: if ($regexp_ok == 1) { 4250: if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) { 4251: $match = 0; 4252: } 4253: } elsif ($regexp_ok == -1) { 4254: if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) { 4255: $match = 0; 4256: } 4257: } else { 4258: if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) { 4259: $match = 0; 4260: } 4261: } 4262: } 4263: if ($ownerfilter ne '.') { 4264: if (!$is_hash) { 4265: $unesc_val{'owner'} = &unescape($val{'owner'}); 4266: } 4267: if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) { 4268: if ($unesc_val{'owner'} =~ /:/) { 4269: if (eval{$unesc_val{'owner'} !~ 4270: /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) { 4271: $match = 0; 4272: } 4273: } else { 4274: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) { 4275: $match = 0; 4276: } 4277: } 4278: } elsif ($ownerunamefilter ne '') { 4279: if ($unesc_val{'owner'} =~ /:/) { 4280: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) { 4281: $match = 0; 4282: } 4283: } else { 4284: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) { 4285: $match = 0; 4286: } 4287: } 4288: } elsif ($ownerdomfilter ne '') { 4289: if ($unesc_val{'owner'} =~ /:/) { 4290: if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) { 4291: $match = 0; 4292: } 4293: } else { 4294: if ($ownerdomfilter ne $udom) { 4295: $match = 0; 4296: } 4297: } 4298: } 4299: } 4300: if ($coursefilter ne '.') { 4301: if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) { 4302: $match = 0; 4303: } 4304: } 4305: if ($typefilter ne '.') { 4306: if (!$is_hash) { 4307: $unesc_val{'type'} = &unescape($val{'type'}); 4308: } 4309: if ($unesc_val{'type'} eq '') { 4310: if ($typefilter ne 'Course') { 4311: $match = 0; 4312: } 4313: } else { 4314: if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) { 4315: $match = 0; 4316: } 4317: } 4318: } 4319: if ($match == 1) { 4320: if ($rtn_as_hash) { 4321: if ($is_hash) { 4322: if ($valchange) { 4323: my $newvalue = &Apache::lonnet::freeze_escape($items); 4324: $qresult.=$key.'='.$newvalue.'&'; 4325: } else { 4326: $qresult.=$key.'='.$value.'&'; 4327: } 4328: } else { 4329: my %rtnhash = ( 'description' => &unescape($val{'descr'}), 4330: 'inst_code' => &unescape($val{'inst_code'}), 4331: 'owner' => &unescape($val{'owner'}), 4332: 'type' => &unescape($val{'type'}), 4333: 'cloners' => &unescape($val{'cloners'}), 4334: ); 4335: my $items = &Apache::lonnet::freeze_escape(\%rtnhash); 4336: $qresult.=$key.'='.$items.'&'; 4337: } 4338: } else { 4339: if ($is_hash) { 4340: $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'. 4341: &escape($unesc_val{'inst_code'}).':'. 4342: &escape($unesc_val{'owner'}).'&'; 4343: } else { 4344: $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}. 4345: ':'.$val{'owner'}.'&'; 4346: } 4347: } 4348: } 4349: } 4350: if (&untie_domain_hash($hashref)) { 4351: chop($qresult); 4352: &Reply($client, \$qresult, $userinput); 4353: } else { 4354: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4355: "while attempting courseiddump\n", $userinput); 4356: } 4357: } else { 4358: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 4359: "while attempting courseiddump\n", $userinput); 4360: } 4361: return 1; 4362: } 4363: &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0); 4364: 4365: sub course_lastaccess_handler { 4366: my ($cmd, $tail, $client) = @_; 4367: my $userinput = "$cmd:$tail"; 4368: my ($cdom,$cnum) = split(':',$tail); 4369: my (%lastaccess,$qresult); 4370: my $hashref = &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT()); 4371: if ($hashref) { 4372: while (my ($key,$value) = each(%$hashref)) { 4373: my ($unesc_key,$lasttime); 4374: $unesc_key = &unescape($key); 4375: if ($cnum) { 4376: next unless ($unesc_key =~ /\Q$cdom\E_\Q$cnum\E$/); 4377: } 4378: if ($unesc_key =~ /^lasttime:($LONCAPA::match_domain\_$LONCAPA::match_courseid)/) { 4379: $lastaccess{$1} = $value; 4380: } else { 4381: my $items = &Apache::lonnet::thaw_unescape($value); 4382: if (ref($items) eq 'HASH') { 4383: unless ($lastaccess{$unesc_key}) { 4384: $lastaccess{$unesc_key} = ''; 4385: } 4386: } else { 4387: my @courseitems = split(':',$value); 4388: $lastaccess{$unesc_key} = pop(@courseitems); 4389: } 4390: } 4391: } 4392: foreach my $cid (sort(keys(%lastaccess))) { 4393: $qresult.=&escape($cid).'='.$lastaccess{$cid}.'&'; 4394: } 4395: if (&untie_domain_hash($hashref)) { 4396: if ($qresult) { 4397: chop($qresult); 4398: } 4399: &Reply($client, \$qresult, $userinput); 4400: } else { 4401: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4402: "while attempting lastacourseaccess\n", $userinput); 4403: } 4404: } else { 4405: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 4406: "while attempting lastcourseaccess\n", $userinput); 4407: } 4408: return 1; 4409: } 4410: &register_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0); 4411: 4412: # 4413: # Puts an unencrypted entry in a namespace db file at the domain level 4414: # 4415: # Parameters: 4416: # $cmd - The command that got us here. 4417: # $tail - Tail of the command (remaining parameters). 4418: # $client - File descriptor connected to client. 4419: # Returns 4420: # 0 - Requested to exit, caller should shut down. 4421: # 1 - Continue processing. 4422: # Side effects: 4423: # reply is written to $client. 4424: # 4425: sub put_domain_handler { 4426: my ($cmd,$tail,$client) = @_; 4427: 4428: my $userinput = "$cmd:$tail"; 4429: 4430: my ($udom,$namespace,$what) =split(/:/,$tail,3); 4431: chomp($what); 4432: my @pairs=split(/\&/,$what); 4433: my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(), 4434: "P", $what); 4435: if ($hashref) { 4436: foreach my $pair (@pairs) { 4437: my ($key,$value)=split(/=/,$pair); 4438: $hashref->{$key}=$value; 4439: } 4440: if (&untie_domain_hash($hashref)) { 4441: &Reply($client, "ok\n", $userinput); 4442: } else { 4443: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4444: "while attempting putdom\n", $userinput); 4445: } 4446: } else { 4447: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 4448: "while attempting putdom\n", $userinput); 4449: } 4450: 4451: return 1; 4452: } 4453: &register_handler("putdom", \&put_domain_handler, 0, 1, 0); 4454: 4455: # Updates one or more entries in clickers.db file at the domain level 4456: # 4457: # Parameters: 4458: # $cmd - The command that got us here. 4459: # $tail - Tail of the command (remaining parameters). 4460: # In this case a colon separated list containing: 4461: # (a) the domain for which we are updating the entries, 4462: # (b) the action required -- add or del -- and 4463: # (c) a &-separated list of entries to add or delete. 4464: # $client - File descriptor connected to client. 4465: # Returns 4466: # 1 - Continue processing. 4467: # 0 - Requested to exit, caller should shut down. 4468: # Side effects: 4469: # reply is written to $client. 4470: # 4471: 4472: 4473: sub update_clickers { 4474: my ($cmd, $tail, $client) = @_; 4475: 4476: my $userinput = "$cmd:$tail"; 4477: my ($udom,$action,$what) =split(/:/,$tail,3); 4478: chomp($what); 4479: 4480: my $hashref = &tie_domain_hash($udom, "clickers", &GDBM_WRCREAT(), 4481: "U","$action:$what"); 4482: 4483: if (!$hashref) { 4484: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 4485: "while attempting updateclickers\n", $userinput); 4486: return 1; 4487: } 4488: 4489: my @pairs=split(/\&/,$what); 4490: foreach my $pair (@pairs) { 4491: my ($key,$value)=split(/=/,$pair); 4492: if ($action eq 'add') { 4493: if (exists($hashref->{$key})) { 4494: my @newvals = split(/,/,&unescape($value)); 4495: my @currvals = split(/,/,&unescape($hashref->{$key})); 4496: my @merged = sort(keys(%{{map { $_ => 1 } (@newvals,@currvals)}})); 4497: $hashref->{$key}=&escape(join(',',@merged)); 4498: } else { 4499: $hashref->{$key}=$value; 4500: } 4501: } elsif ($action eq 'del') { 4502: if (exists($hashref->{$key})) { 4503: my %current; 4504: map { $current{$_} = 1; } split(/,/,&unescape($hashref->{$key})); 4505: map { delete($current{$_}); } split(/,/,&unescape($value)); 4506: if (keys(%current)) { 4507: $hashref->{$key}=&escape(join(',',sort(keys(%current)))); 4508: } else { 4509: delete($hashref->{$key}); 4510: } 4511: } 4512: } 4513: } 4514: if (&untie_user_hash($hashref)) { 4515: &Reply( $client, "ok\n", $userinput); 4516: } else { 4517: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ". 4518: "while attempting put\n", 4519: $userinput); 4520: } 4521: return 1; 4522: } 4523: &register_handler("updateclickers", \&update_clickers, 0, 1, 0); 4524: 4525: 4526: # Deletes one or more entries in a namespace db file at the domain level 4527: # 4528: # Parameters: 4529: # $cmd - The command that got us here. 4530: # $tail - Tail of the command (remaining parameters). 4531: # In this case a colon separated list containing: 4532: # (a) the domain for which we are deleting the entries, 4533: # (b) &-separated list of keys to delete. 4534: # $client - File descriptor connected to client. 4535: # Returns 4536: # 1 - Continue processing. 4537: # 0 - Requested to exit, caller should shut down. 4538: # Side effects: 4539: # reply is written to $client. 4540: # 4541: 4542: sub del_domain_handler { 4543: my ($cmd,$tail,$client) = @_; 4544: 4545: my $userinput = "$cmd:$tail"; 4546: 4547: my ($udom,$namespace,$what)=split(/:/,$tail,3); 4548: chomp($what); 4549: my $hashref = &tie_domain_hash($udom,$namespace,&GDBM_WRCREAT(), 4550: "D", $what); 4551: if ($hashref) { 4552: my @keys=split(/\&/,$what); 4553: foreach my $key (@keys) { 4554: delete($hashref->{$key}); 4555: } 4556: if (&untie_user_hash($hashref)) { 4557: &Reply($client, "ok\n", $userinput); 4558: } else { 4559: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4560: "while attempting deldom\n", $userinput); 4561: } 4562: } else { 4563: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 4564: "while attempting deldom\n", $userinput); 4565: } 4566: return 1; 4567: } 4568: &register_handler("deldom", \&del_domain_handler, 0, 1, 0); 4569: 4570: 4571: # Unencrypted get from the namespace database file at the domain level. 4572: # This function retrieves a keyed item from a specific named database in the 4573: # domain directory. 4574: # 4575: # Parameters: 4576: # $cmd - Command request keyword (get). 4577: # $tail - Tail of the command. This is a colon separated list 4578: # consisting of the domain and the 'namespace' 4579: # which selects the gdbm file to do the lookup in, 4580: # & separated list of keys to lookup. Note that 4581: # the values are returned as an & separated list too. 4582: # $client - File descriptor open on the client. 4583: # Returns: 4584: # 1 - Continue processing. 4585: # 0 - Exit. 4586: # Side effects: 4587: # reply is written to $client. 4588: # 4589: 4590: sub get_domain_handler { 4591: my ($cmd, $tail, $client) = @_; 4592: 4593: 4594: my $userinput = "$client:$tail"; 4595: 4596: my ($udom,$namespace,$what)=split(/:/,$tail,3); 4597: chomp($what); 4598: my @queries=split(/\&/,$what); 4599: my $qresult=''; 4600: my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER()); 4601: if ($hashref) { 4602: for (my $i=0;$i<=$#queries;$i++) { 4603: $qresult.="$hashref->{$queries[$i]}&"; 4604: } 4605: if (&untie_domain_hash($hashref)) { 4606: $qresult=~s/\&$//; 4607: &Reply($client, \$qresult, $userinput); 4608: } else { 4609: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 4610: "while attempting getdom\n",$userinput); 4611: } 4612: } else { 4613: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 4614: "while attempting getdom\n",$userinput); 4615: } 4616: 4617: return 1; 4618: } 4619: &register_handler("getdom", \&get_domain_handler, 0, 1, 0); 4620: 4621: # 4622: # Puts an id to a domains id database. 4623: # 4624: # Parameters: 4625: # $cmd - The command that triggered us. 4626: # $tail - Remainder of the request other than the command. This is a 4627: # colon separated list containing: 4628: # $domain - The domain for which we are writing the id. 4629: # $pairs - The id info to write... this is and & separated list 4630: # of keyword=value. 4631: # $client - Socket open on the client. 4632: # Returns: 4633: # 1 - Continue processing. 4634: # Side effects: 4635: # reply is written to $client. 4636: # 4637: sub put_id_handler { 4638: my ($cmd,$tail,$client) = @_; 4639: 4640: 4641: my $userinput = "$cmd:$tail"; 4642: 4643: my ($udom,$what)=split(/:/,$tail); 4644: chomp($what); 4645: my @pairs=split(/\&/,$what); 4646: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(), 4647: "P", $what); 4648: if ($hashref) { 4649: foreach my $pair (@pairs) { 4650: my ($key,$value)=split(/=/,$pair); 4651: $hashref->{$key}=$value; 4652: } 4653: if (&untie_domain_hash($hashref)) { 4654: &Reply($client, "ok\n", $userinput); 4655: } else { 4656: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4657: "while attempting idput\n", $userinput); 4658: } 4659: } else { 4660: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 4661: "while attempting idput\n", $userinput); 4662: } 4663: 4664: return 1; 4665: } 4666: &register_handler("idput", \&put_id_handler, 0, 1, 0); 4667: 4668: # 4669: # Retrieves a set of id values from the id database. 4670: # Returns an & separated list of results, one for each requested id to the 4671: # client. 4672: # 4673: # Parameters: 4674: # $cmd - Command keyword that caused us to be dispatched. 4675: # $tail - Tail of the command. Consists of a colon separated: 4676: # domain - the domain whose id table we dump 4677: # ids Consists of an & separated list of 4678: # id keywords whose values will be fetched. 4679: # nonexisting keywords will have an empty value. 4680: # $client - Socket open on the client. 4681: # 4682: # Returns: 4683: # 1 - indicating processing should continue. 4684: # Side effects: 4685: # An & separated list of results is written to $client. 4686: # 4687: sub get_id_handler { 4688: my ($cmd, $tail, $client) = @_; 4689: 4690: 4691: my $userinput = "$client:$tail"; 4692: 4693: my ($udom,$what)=split(/:/,$tail); 4694: chomp($what); 4695: my @queries=split(/\&/,$what); 4696: my $qresult=''; 4697: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_READER()); 4698: if ($hashref) { 4699: for (my $i=0;$i<=$#queries;$i++) { 4700: $qresult.="$hashref->{$queries[$i]}&"; 4701: } 4702: if (&untie_domain_hash($hashref)) { 4703: $qresult=~s/\&$//; 4704: &Reply($client, \$qresult, $userinput); 4705: } else { 4706: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 4707: "while attempting idget\n",$userinput); 4708: } 4709: } else { 4710: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 4711: "while attempting idget\n",$userinput); 4712: } 4713: 4714: return 1; 4715: } 4716: &register_handler("idget", \&get_id_handler, 0, 1, 0); 4717: 4718: # Deletes one or more ids in a domain's id database. 4719: # 4720: # Parameters: 4721: # $cmd - Command keyword (iddel). 4722: # $tail - Command tail. In this case a colon 4723: # separated list containing: 4724: # The domain for which we are deleting the id(s). 4725: # &-separated list of id(s) to delete. 4726: # $client - File open on client socket. 4727: # Returns: 4728: # 1 - Continue processing 4729: # 0 - Exit server. 4730: # 4731: # 4732: 4733: sub del_id_handler { 4734: my ($cmd,$tail,$client) = @_; 4735: 4736: my $userinput = "$cmd:$tail"; 4737: 4738: my ($udom,$what)=split(/:/,$tail); 4739: chomp($what); 4740: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(), 4741: "D", $what); 4742: if ($hashref) { 4743: my @keys=split(/\&/,$what); 4744: foreach my $key (@keys) { 4745: delete($hashref->{$key}); 4746: } 4747: if (&untie_user_hash($hashref)) { 4748: &Reply($client, "ok\n", $userinput); 4749: } else { 4750: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4751: "while attempting iddel\n", $userinput); 4752: } 4753: } else { 4754: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 4755: "while attempting iddel\n", $userinput); 4756: } 4757: return 1; 4758: } 4759: &register_handler("iddel", \&del_id_handler, 0, 1, 0); 4760: 4761: # 4762: # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database 4763: # 4764: # Parameters 4765: # $cmd - Command keyword that caused us to be dispatched. 4766: # $tail - Tail of the command. Consists of a colon separated: 4767: # domain - the domain whose dcmail we are recording 4768: # email Consists of key=value pair 4769: # where key is unique msgid 4770: # and value is message (in XML) 4771: # $client - Socket open on the client. 4772: # 4773: # Returns: 4774: # 1 - indicating processing should continue. 4775: # Side effects 4776: # reply is written to $client. 4777: # 4778: sub put_dcmail_handler { 4779: my ($cmd,$tail,$client) = @_; 4780: my $userinput = "$cmd:$tail"; 4781: 4782: 4783: my ($udom,$what)=split(/:/,$tail); 4784: chomp($what); 4785: my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); 4786: if ($hashref) { 4787: my ($key,$value)=split(/=/,$what); 4788: $hashref->{$key}=$value; 4789: } 4790: if (&untie_domain_hash($hashref)) { 4791: &Reply($client, "ok\n", $userinput); 4792: } else { 4793: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4794: "while attempting dcmailput\n", $userinput); 4795: } 4796: return 1; 4797: } 4798: &register_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0); 4799: 4800: # 4801: # Retrieves broadcast e-mail from nohist_dcmail database 4802: # Returns to client an & separated list of key=value pairs, 4803: # where key is msgid and value is message information. 4804: # 4805: # Parameters 4806: # $cmd - Command keyword that caused us to be dispatched. 4807: # $tail - Tail of the command. Consists of a colon separated: 4808: # domain - the domain whose dcmail table we dump 4809: # startfilter - beginning of time window 4810: # endfilter - end of time window 4811: # sendersfilter - & separated list of username:domain 4812: # for senders to search for. 4813: # $client - Socket open on the client. 4814: # 4815: # Returns: 4816: # 1 - indicating processing should continue. 4817: # Side effects 4818: # reply (& separated list of msgid=messageinfo pairs) is 4819: # written to $client. 4820: # 4821: sub dump_dcmail_handler { 4822: my ($cmd, $tail, $client) = @_; 4823: 4824: my $userinput = "$cmd:$tail"; 4825: my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail); 4826: chomp($sendersfilter); 4827: my @senders = (); 4828: if (defined($startfilter)) { 4829: $startfilter=&unescape($startfilter); 4830: } else { 4831: $startfilter='.'; 4832: } 4833: if (defined($endfilter)) { 4834: $endfilter=&unescape($endfilter); 4835: } else { 4836: $endfilter='.'; 4837: } 4838: if (defined($sendersfilter)) { 4839: $sendersfilter=&unescape($sendersfilter); 4840: @senders = map { &unescape($_) } split(/\&/,$sendersfilter); 4841: } 4842: 4843: my $qresult=''; 4844: my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); 4845: if ($hashref) { 4846: while (my ($key,$value) = each(%$hashref)) { 4847: my $match = 1; 4848: my ($timestamp,$subj,$uname,$udom) = 4849: split(/:/,&unescape(&unescape($key)),5); # yes, twice really 4850: $subj = &unescape($subj); 4851: unless ($startfilter eq '.' || !defined($startfilter)) { 4852: if ($timestamp < $startfilter) { 4853: $match = 0; 4854: } 4855: } 4856: unless ($endfilter eq '.' || !defined($endfilter)) { 4857: if ($timestamp > $endfilter) { 4858: $match = 0; 4859: } 4860: } 4861: unless (@senders < 1) { 4862: unless (grep/^$uname:$udom$/,@senders) { 4863: $match = 0; 4864: } 4865: } 4866: if ($match == 1) { 4867: $qresult.=$key.'='.$value.'&'; 4868: } 4869: } 4870: if (&untie_domain_hash($hashref)) { 4871: chop($qresult); 4872: &Reply($client, \$qresult, $userinput); 4873: } else { 4874: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4875: "while attempting dcmaildump\n", $userinput); 4876: } 4877: } else { 4878: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 4879: "while attempting dcmaildump\n", $userinput); 4880: } 4881: return 1; 4882: } 4883: 4884: &register_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0); 4885: 4886: # 4887: # Puts domain roles in nohist_domainroles database 4888: # 4889: # Parameters 4890: # $cmd - Command keyword that caused us to be dispatched. 4891: # $tail - Tail of the command. Consists of a colon separated: 4892: # domain - the domain whose roles we are recording 4893: # role - Consists of key=value pair 4894: # where key is unique role 4895: # and value is start/end date information 4896: # $client - Socket open on the client. 4897: # 4898: # Returns: 4899: # 1 - indicating processing should continue. 4900: # Side effects 4901: # reply is written to $client. 4902: # 4903: 4904: sub put_domainroles_handler { 4905: my ($cmd,$tail,$client) = @_; 4906: 4907: my $userinput = "$cmd:$tail"; 4908: my ($udom,$what)=split(/:/,$tail); 4909: chomp($what); 4910: my @pairs=split(/\&/,$what); 4911: my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); 4912: if ($hashref) { 4913: foreach my $pair (@pairs) { 4914: my ($key,$value)=split(/=/,$pair); 4915: $hashref->{$key}=$value; 4916: } 4917: if (&untie_domain_hash($hashref)) { 4918: &Reply($client, "ok\n", $userinput); 4919: } else { 4920: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 4921: "while attempting domroleput\n", $userinput); 4922: } 4923: } else { 4924: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 4925: "while attempting domroleput\n", $userinput); 4926: } 4927: 4928: return 1; 4929: } 4930: 4931: &register_handler("domroleput", \&put_domainroles_handler, 0, 1, 0); 4932: 4933: # 4934: # Retrieves domain roles from nohist_domainroles database 4935: # Returns to client an & separated list of key=value pairs, 4936: # where key is role and value is start and end date information. 4937: # 4938: # Parameters 4939: # $cmd - Command keyword that caused us to be dispatched. 4940: # $tail - Tail of the command. Consists of a colon separated: 4941: # domain - the domain whose domain roles table we dump 4942: # $client - Socket open on the client. 4943: # 4944: # Returns: 4945: # 1 - indicating processing should continue. 4946: # Side effects 4947: # reply (& separated list of role=start/end info pairs) is 4948: # written to $client. 4949: # 4950: sub dump_domainroles_handler { 4951: my ($cmd, $tail, $client) = @_; 4952: 4953: my $userinput = "$cmd:$tail"; 4954: my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail); 4955: chomp($rolesfilter); 4956: my @roles = (); 4957: if (defined($startfilter)) { 4958: $startfilter=&unescape($startfilter); 4959: } else { 4960: $startfilter='.'; 4961: } 4962: if (defined($endfilter)) { 4963: $endfilter=&unescape($endfilter); 4964: } else { 4965: $endfilter='.'; 4966: } 4967: if (defined($rolesfilter)) { 4968: $rolesfilter=&unescape($rolesfilter); 4969: @roles = split(/\&/,$rolesfilter); 4970: } 4971: 4972: my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); 4973: if ($hashref) { 4974: my $qresult = ''; 4975: while (my ($key,$value) = each(%$hashref)) { 4976: my $match = 1; 4977: my ($end,$start) = split(/:/,&unescape($value)); 4978: my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key)); 4979: unless (@roles < 1) { 4980: unless (grep/^\Q$trole\E$/,@roles) { 4981: $match = 0; 4982: next; 4983: } 4984: } 4985: unless ($startfilter eq '.' || !defined($startfilter)) { 4986: if ((defined($start)) && ($start >= $startfilter)) { 4987: $match = 0; 4988: next; 4989: } 4990: } 4991: unless ($endfilter eq '.' || !defined($endfilter)) { 4992: if ((defined($end)) && (($end > 0) && ($end <= $endfilter))) { 4993: $match = 0; 4994: next; 4995: } 4996: } 4997: if ($match == 1) { 4998: $qresult.=$key.'='.$value.'&'; 4999: } 5000: } 5001: if (&untie_domain_hash($hashref)) { 5002: chop($qresult); 5003: &Reply($client, \$qresult, $userinput); 5004: } else { 5005: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 5006: "while attempting domrolesdump\n", $userinput); 5007: } 5008: } else { 5009: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 5010: "while attempting domrolesdump\n", $userinput); 5011: } 5012: return 1; 5013: } 5014: 5015: &register_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0); 5016: 5017: 5018: # Process the tmpput command I'm not sure what this does.. Seems to 5019: # create a file in the lonDaemons/tmp directory of the form $id.tmp 5020: # where Id is the client's ip concatenated with a sequence number. 5021: # The file will contain some value that is passed in. Is this e.g. 5022: # a login token? 5023: # 5024: # Parameters: 5025: # $cmd - The command that got us dispatched. 5026: # $tail - The remainder of the request following $cmd: 5027: # In this case this will be the contents of the file. 5028: # $client - Socket connected to the client. 5029: # Returns: 5030: # 1 indicating processing can continue. 5031: # Side effects: 5032: # A file is created in the local filesystem. 5033: # A reply is sent to the client. 5034: sub tmp_put_handler { 5035: my ($cmd, $what, $client) = @_; 5036: 5037: my $userinput = "$cmd:$what"; # Reconstruct for logging. 5038: 5039: my ($record,$context) = split(/:/,$what); 5040: if ($context ne '') { 5041: chomp($context); 5042: $context = &unescape($context); 5043: } 5044: my ($id,$store); 5045: $tmpsnum++; 5046: if (($context eq 'resetpw') || ($context eq 'createaccount')) { 5047: $id = &md5_hex(&md5_hex(time.{}.rand().$$)); 5048: } else { 5049: $id = $$.'_'.$clientip.'_'.$tmpsnum; 5050: } 5051: $id=~s/\W/\_/g; 5052: $record=~s/\n//g; 5053: my $execdir=$perlvar{'lonDaemons'}; 5054: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { 5055: print $store $record; 5056: close $store; 5057: &Reply($client, \$id, $userinput); 5058: } else { 5059: &Failure( $client, "error: ".($!+0)."IO::File->new Failed ". 5060: "while attempting tmpput\n", $userinput); 5061: } 5062: return 1; 5063: 5064: } 5065: &register_handler("tmpput", \&tmp_put_handler, 0, 1, 0); 5066: 5067: # Processes the tmpget command. This command returns the contents 5068: # of a temporary resource file(?) created via tmpput. 5069: # 5070: # Paramters: 5071: # $cmd - Command that got us dispatched. 5072: # $id - Tail of the command, contain the id of the resource 5073: # we want to fetch. 5074: # $client - socket open on the client. 5075: # Return: 5076: # 1 - Inidcating processing can continue. 5077: # Side effects: 5078: # A reply is sent to the client. 5079: # 5080: sub tmp_get_handler { 5081: my ($cmd, $id, $client) = @_; 5082: 5083: my $userinput = "$cmd:$id"; 5084: 5085: 5086: $id=~s/\W/\_/g; 5087: my $store; 5088: my $execdir=$perlvar{'lonDaemons'}; 5089: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { 5090: my $reply=<$store>; 5091: &Reply( $client, \$reply, $userinput); 5092: close $store; 5093: } else { 5094: &Failure( $client, "error: ".($!+0)."IO::File->new Failed ". 5095: "while attempting tmpget\n", $userinput); 5096: } 5097: 5098: return 1; 5099: } 5100: &register_handler("tmpget", \&tmp_get_handler, 0, 1, 0); 5101: 5102: # 5103: # Process the tmpdel command. This command deletes a temp resource 5104: # created by the tmpput command. 5105: # 5106: # Parameters: 5107: # $cmd - Command that got us here. 5108: # $id - Id of the temporary resource created. 5109: # $client - socket open on the client process. 5110: # 5111: # Returns: 5112: # 1 - Indicating processing should continue. 5113: # Side Effects: 5114: # A file is deleted 5115: # A reply is sent to the client. 5116: sub tmp_del_handler { 5117: my ($cmd, $id, $client) = @_; 5118: 5119: my $userinput= "$cmd:$id"; 5120: 5121: chomp($id); 5122: $id=~s/\W/\_/g; 5123: my $execdir=$perlvar{'lonDaemons'}; 5124: if (unlink("$execdir/tmp/$id.tmp")) { 5125: &Reply($client, "ok\n", $userinput); 5126: } else { 5127: &Failure( $client, "error: ".($!+0)."Unlink tmp Failed ". 5128: "while attempting tmpdel\n", $userinput); 5129: } 5130: 5131: return 1; 5132: 5133: } 5134: &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0); 5135: 5136: # 5137: # Processes the setannounce command. This command 5138: # creates a file named announce.txt in the top directory of 5139: # the documentn root and sets its contents. The announce.txt file is 5140: # printed in its entirety at the LonCAPA login page. Note: 5141: # once the announcement.txt fileis created it cannot be deleted. 5142: # However, setting the contents of the file to empty removes the 5143: # announcement from the login page of loncapa so who cares. 5144: # 5145: # Parameters: 5146: # $cmd - The command that got us dispatched. 5147: # $announcement - The text of the announcement. 5148: # $client - Socket open on the client process. 5149: # Retunrns: 5150: # 1 - Indicating request processing should continue 5151: # Side Effects: 5152: # The file {DocRoot}/announcement.txt is created. 5153: # A reply is sent to $client. 5154: # 5155: sub set_announce_handler { 5156: my ($cmd, $announcement, $client) = @_; 5157: 5158: my $userinput = "$cmd:$announcement"; 5159: 5160: chomp($announcement); 5161: $announcement=&unescape($announcement); 5162: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. 5163: '/announcement.txt')) { 5164: print $store $announcement; 5165: close $store; 5166: &Reply($client, "ok\n", $userinput); 5167: } else { 5168: &Failure($client, "error: ".($!+0)."\n", $userinput); 5169: } 5170: 5171: return 1; 5172: } 5173: &register_handler("setannounce", \&set_announce_handler, 0, 1, 0); 5174: 5175: # 5176: # Return the version of the daemon. This can be used to determine 5177: # the compatibility of cross version installations or, alternatively to 5178: # simply know who's out of date and who isn't. Note that the version 5179: # is returned concatenated with the tail. 5180: # Parameters: 5181: # $cmd - the request that dispatched to us. 5182: # $tail - Tail of the request (client's version?). 5183: # $client - Socket open on the client. 5184: #Returns: 5185: # 1 - continue processing requests. 5186: # Side Effects: 5187: # Replies with version to $client. 5188: sub get_version_handler { 5189: my ($cmd, $tail, $client) = @_; 5190: 5191: my $userinput = $cmd.$tail; 5192: 5193: &Reply($client, &version($userinput)."\n", $userinput); 5194: 5195: 5196: return 1; 5197: } 5198: &register_handler("version", \&get_version_handler, 0, 1, 0); 5199: 5200: # Set the current host and domain. This is used to support 5201: # multihomed systems. Each IP of the system, or even separate daemons 5202: # on the same IP can be treated as handling a separate lonCAPA virtual 5203: # machine. This command selects the virtual lonCAPA. The client always 5204: # knows the right one since it is lonc and it is selecting the domain/system 5205: # from the hosts.tab file. 5206: # Parameters: 5207: # $cmd - Command that dispatched us. 5208: # $tail - Tail of the command (domain/host requested). 5209: # $socket - Socket open on the client. 5210: # 5211: # Returns: 5212: # 1 - Indicates the program should continue to process requests. 5213: # Side-effects: 5214: # The default domain/system context is modified for this daemon. 5215: # a reply is sent to the client. 5216: # 5217: sub set_virtual_host_handler { 5218: my ($cmd, $tail, $socket) = @_; 5219: 5220: my $userinput ="$cmd:$tail"; 5221: 5222: &Reply($client, &sethost($userinput)."\n", $userinput); 5223: 5224: 5225: return 1; 5226: } 5227: &register_handler("sethost", \&set_virtual_host_handler, 0, 1, 0); 5228: 5229: # Process a request to exit: 5230: # - "bye" is sent to the client. 5231: # - The client socket is shutdown and closed. 5232: # - We indicate to the caller that we should exit. 5233: # Formal Parameters: 5234: # $cmd - The command that got us here. 5235: # $tail - Tail of the command (empty). 5236: # $client - Socket open on the tail. 5237: # Returns: 5238: # 0 - Indicating the program should exit!! 5239: # 5240: sub exit_handler { 5241: my ($cmd, $tail, $client) = @_; 5242: 5243: my $userinput = "$cmd:$tail"; 5244: 5245: &logthis("Client $clientip ($clientname) hanging up: $userinput"); 5246: &Reply($client, "bye\n", $userinput); 5247: $client->shutdown(2); # shutdown the socket forcibly. 5248: $client->close(); 5249: 5250: return 0; 5251: } 5252: &register_handler("exit", \&exit_handler, 0,1,1); 5253: &register_handler("init", \&exit_handler, 0,1,1); 5254: &register_handler("quit", \&exit_handler, 0,1,1); 5255: 5256: # Determine if auto-enrollment is enabled. 5257: # Note that the original had what I believe to be a defect. 5258: # The original returned 0 if the requestor was not a registerd client. 5259: # It should return "refused". 5260: # Formal Parameters: 5261: # $cmd - The command that invoked us. 5262: # $tail - The tail of the command (Extra command parameters. 5263: # $client - The socket open on the client that issued the request. 5264: # Returns: 5265: # 1 - Indicating processing should continue. 5266: # 5267: sub enrollment_enabled_handler { 5268: my ($cmd, $tail, $client) = @_; 5269: my $userinput = $cmd.":".$tail; # For logging purposes. 5270: 5271: 5272: my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about. 5273: 5274: my $outcome = &localenroll::run($cdom); 5275: &Reply($client, \$outcome, $userinput); 5276: 5277: return 1; 5278: } 5279: &register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0); 5280: 5281: # 5282: # Validate an institutional code used for a LON-CAPA course. 5283: # 5284: # Formal Parameters: 5285: # $cmd - The command request that got us dispatched. 5286: # $tail - The tail of the command. In this case, 5287: # this is a colon separated set of words that will be split 5288: # into: 5289: # $dom - The domain for which the check of 5290: # institutional course code will occur. 5291: # 5292: # $instcode - The institutional code for the course 5293: # being requested, or validated for rights 5294: # to request. 5295: # 5296: # $owner - The course requestor (who will be the 5297: # course owner, in the form username:domain 5298: # 5299: # $client - Socket open on the client. 5300: # Returns: 5301: # 1 - Indicating processing should continue. 5302: # 5303: sub validate_instcode_handler { 5304: my ($cmd, $tail, $client) = @_; 5305: my $userinput = "$cmd:$tail"; 5306: my ($dom,$instcode,$owner) = split(/:/, $tail); 5307: $instcode = &unescape($instcode); 5308: $owner = &unescape($owner); 5309: my ($outcome,$description,$credits) = 5310: &localenroll::validate_instcode($dom,$instcode,$owner); 5311: my $result = &escape($outcome).'&'.&escape($description).'&'. 5312: &escape($credits); 5313: &Reply($client, \$result, $userinput); 5314: 5315: return 1; 5316: } 5317: &register_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0); 5318: 5319: # Get the official sections for which auto-enrollment is possible. 5320: # Since the admin people won't know about 'unofficial sections' 5321: # we cannot auto-enroll on them. 5322: # Formal Parameters: 5323: # $cmd - The command request that got us dispatched here. 5324: # $tail - The remainder of the request. In our case this 5325: # will be split into: 5326: # $coursecode - The course name from the admin point of view. 5327: # $cdom - The course's domain(?). 5328: # $client - Socket open on the client. 5329: # Returns: 5330: # 1 - Indiciting processing should continue. 5331: # 5332: sub get_sections_handler { 5333: my ($cmd, $tail, $client) = @_; 5334: my $userinput = "$cmd:$tail"; 5335: 5336: my ($coursecode, $cdom) = split(/:/, $tail); 5337: my @secs = &localenroll::get_sections($coursecode,$cdom); 5338: my $seclist = &escape(join(':',@secs)); 5339: 5340: &Reply($client, \$seclist, $userinput); 5341: 5342: 5343: return 1; 5344: } 5345: &register_handler("autogetsections", \&get_sections_handler, 0, 1, 0); 5346: 5347: # Validate the owner of a new course section. 5348: # 5349: # Formal Parameters: 5350: # $cmd - Command that got us dispatched. 5351: # $tail - the remainder of the command. For us this consists of a 5352: # colon separated string containing: 5353: # $inst - Course Id from the institutions point of view. 5354: # $owner - Proposed owner of the course. 5355: # $cdom - Domain of the course (from the institutions 5356: # point of view?).. 5357: # $client - Socket open on the client. 5358: # 5359: # Returns: 5360: # 1 - Processing should continue. 5361: # 5362: sub validate_course_owner_handler { 5363: my ($cmd, $tail, $client) = @_; 5364: my $userinput = "$cmd:$tail"; 5365: my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail); 5366: 5367: $owner = &unescape($owner); 5368: $coowners = &unescape($coowners); 5369: my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners); 5370: &Reply($client, \$outcome, $userinput); 5371: 5372: 5373: 5374: return 1; 5375: } 5376: &register_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0); 5377: 5378: # 5379: # Validate a course section in the official schedule of classes 5380: # from the institutions point of view (part of autoenrollment). 5381: # 5382: # Formal Parameters: 5383: # $cmd - The command request that got us dispatched. 5384: # $tail - The tail of the command. In this case, 5385: # this is a colon separated set of words that will be split 5386: # into: 5387: # $inst_course_id - The course/section id from the 5388: # institutions point of view. 5389: # $cdom - The domain from the institutions 5390: # point of view. 5391: # $client - Socket open on the client. 5392: # Returns: 5393: # 1 - Indicating processing should continue. 5394: # 5395: sub validate_course_section_handler { 5396: my ($cmd, $tail, $client) = @_; 5397: my $userinput = "$cmd:$tail"; 5398: my ($inst_course_id, $cdom) = split(/:/, $tail); 5399: 5400: my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom); 5401: &Reply($client, \$outcome, $userinput); 5402: 5403: 5404: return 1; 5405: } 5406: &register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0); 5407: 5408: # 5409: # Validate course owner's access to enrollment data for specific class section. 5410: # 5411: # 5412: # Formal Parameters: 5413: # $cmd - The command request that got us dispatched. 5414: # $tail - The tail of the command. In this case this is a colon separated 5415: # set of words that will be split into: 5416: # $inst_class - Institutional code for the specific class section 5417: # $courseowner - The escaped username:domain of the course owner 5418: # $cdom - The domain of the course from the institution's 5419: # point of view. 5420: # $client - The socket open on the client. 5421: # Returns: 5422: # 1 - continue processing. 5423: # 5424: 5425: sub validate_class_access_handler { 5426: my ($cmd, $tail, $client) = @_; 5427: my $userinput = "$cmd:$tail"; 5428: my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail); 5429: my $owners = &unescape($ownerlist); 5430: my $outcome; 5431: eval { 5432: local($SIG{__DIE__})='DEFAULT'; 5433: $outcome=&localenroll::check_section($inst_class,$owners,$cdom); 5434: }; 5435: &Reply($client,\$outcome, $userinput); 5436: 5437: return 1; 5438: } 5439: &register_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0); 5440: 5441: # 5442: # Create a password for a new LON-CAPA user added by auto-enrollment. 5443: # Only used for case where authentication method for new user is localauth 5444: # 5445: # Formal Parameters: 5446: # $cmd - The command request that got us dispatched. 5447: # $tail - The tail of the command. In this case this is a colon separated 5448: # set of words that will be split into: 5449: # $authparam - An authentication parameter (localauth parameter). 5450: # $cdom - The domain of the course from the institution's 5451: # point of view. 5452: # $client - The socket open on the client. 5453: # Returns: 5454: # 1 - continue processing. 5455: # 5456: sub create_auto_enroll_password_handler { 5457: my ($cmd, $tail, $client) = @_; 5458: my $userinput = "$cmd:$tail"; 5459: 5460: my ($authparam, $cdom) = split(/:/, $userinput); 5461: 5462: my ($create_passwd,$authchk); 5463: ($authparam, 5464: $create_passwd, 5465: $authchk) = &localenroll::create_password($authparam,$cdom); 5466: 5467: &Reply($client, &escape($authparam.':'.$create_passwd.':'.$authchk)."\n", 5468: $userinput); 5469: 5470: 5471: return 1; 5472: } 5473: &register_handler("autocreatepassword", \&create_auto_enroll_password_handler, 5474: 0, 1, 0); 5475: 5476: sub auto_export_grades_handler { 5477: my ($cmd, $tail, $client) = @_; 5478: my $userinput = "$cmd:$tail"; 5479: my ($cdom,$cnum,$info,$data) = split(/:/,$tail); 5480: my $inforef = &Apache::lonnet::thaw_unescape($info); 5481: my $dataref = &Apache::lonnet::thaw_unescape($data); 5482: my ($outcome,$result);; 5483: eval { 5484: local($SIG{__DIE__})='DEFAULT'; 5485: my %rtnhash; 5486: $outcome=&localenroll::export_grades($cdom,$cnum,$inforef,$dataref,\%rtnhash); 5487: if ($outcome eq 'ok') { 5488: foreach my $key (keys(%rtnhash)) { 5489: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rtnhash{$key}).'&'; 5490: } 5491: $result =~ s/\&$//; 5492: } 5493: }; 5494: if (!$@) { 5495: if ($outcome eq 'ok') { 5496: if ($cipher) { 5497: my $cmdlength=length($result); 5498: $result.=" "; 5499: my $encresult=''; 5500: for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { 5501: $encresult.= unpack("H16", 5502: $cipher->encrypt(substr($result, 5503: $encidx, 5504: 8))); 5505: } 5506: &Reply( $client, "enc:$cmdlength:$encresult\n", $userinput); 5507: } else { 5508: &Failure( $client, "error:no_key\n", $userinput); 5509: } 5510: } else { 5511: &Reply($client, "$outcome\n", $userinput); 5512: } 5513: } else { 5514: &Failure($client,"export_error\n",$userinput); 5515: } 5516: return 1; 5517: } 5518: &register_handler("autoexportgrades", \&auto_export_grades_handler, 5519: 0, 1, 0); 5520: 5521: # Retrieve and remove temporary files created by/during autoenrollment. 5522: # 5523: # Formal Parameters: 5524: # $cmd - The command that got us dispatched. 5525: # $tail - The tail of the command. In our case this is a colon 5526: # separated list that will be split into: 5527: # $filename - The name of the file to remove. 5528: # The filename is given as a path relative to 5529: # the LonCAPA temp file directory. 5530: # $client - Socket open on the client. 5531: # 5532: # Returns: 5533: # 1 - Continue processing. 5534: sub retrieve_auto_file_handler { 5535: my ($cmd, $tail, $client) = @_; 5536: my $userinput = "cmd:$tail"; 5537: 5538: my ($filename) = split(/:/, $tail); 5539: 5540: my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename; 5541: 5542: if ($filename =~m{/\.\./}) { 5543: &Failure($client, "refused\n", $userinput); 5544: } elsif ( (-e $source) && ($filename ne '') ) { 5545: my $reply = ''; 5546: if (open(my $fh,$source)) { 5547: while (<$fh>) { 5548: chomp($_); 5549: $_ =~ s/^\s+//g; 5550: $_ =~ s/\s+$//g; 5551: $reply .= $_; 5552: } 5553: close($fh); 5554: &Reply($client, &escape($reply)."\n", $userinput); 5555: 5556: # Does this have to be uncommented??!? (RF). 5557: # 5558: # unlink($source); 5559: } else { 5560: &Failure($client, "error\n", $userinput); 5561: } 5562: } else { 5563: &Failure($client, "error\n", $userinput); 5564: } 5565: 5566: 5567: return 1; 5568: } 5569: &register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0); 5570: 5571: sub crsreq_checks_handler { 5572: my ($cmd, $tail, $client) = @_; 5573: my $userinput = "$cmd:$tail"; 5574: my $dom = $tail; 5575: my $result; 5576: my @reqtypes = ('official','unofficial','community','textbook','placement'); 5577: eval { 5578: local($SIG{__DIE__})='DEFAULT'; 5579: my %validations; 5580: my $response = &localenroll::crsreq_checks($dom,\@reqtypes, 5581: \%validations); 5582: if ($response eq 'ok') { 5583: foreach my $key (keys(%validations)) { 5584: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&'; 5585: } 5586: $result =~ s/\&$//; 5587: } else { 5588: $result = 'error'; 5589: } 5590: }; 5591: if (!$@) { 5592: &Reply($client, \$result, $userinput); 5593: } else { 5594: &Failure($client,"unknown_cmd\n",$userinput); 5595: } 5596: return 1; 5597: } 5598: &register_handler("autocrsreqchecks", \&crsreq_checks_handler, 0, 1, 0); 5599: 5600: sub validate_crsreq_handler { 5601: my ($cmd, $tail, $client) = @_; 5602: my $userinput = "$cmd:$tail"; 5603: my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$customdata) = split(/:/, $tail); 5604: $instcode = &unescape($instcode); 5605: $owner = &unescape($owner); 5606: $crstype = &unescape($crstype); 5607: $inststatuslist = &unescape($inststatuslist); 5608: $instcode = &unescape($instcode); 5609: $instseclist = &unescape($instseclist); 5610: my $custominfo = &Apache::lonnet::thaw_unescape($customdata); 5611: my $outcome; 5612: eval { 5613: local($SIG{__DIE__})='DEFAULT'; 5614: $outcome = &localenroll::validate_crsreq($dom,$owner,$crstype, 5615: $inststatuslist,$instcode, 5616: $instseclist,$custominfo); 5617: }; 5618: if (!$@) { 5619: &Reply($client, \$outcome, $userinput); 5620: } else { 5621: &Failure($client,"unknown_cmd\n",$userinput); 5622: } 5623: return 1; 5624: } 5625: &register_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0); 5626: 5627: sub crsreq_update_handler { 5628: my ($cmd, $tail, $client) = @_; 5629: my $userinput = "$cmd:$tail"; 5630: my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,$code, 5631: $accessstart,$accessend,$infohashref) = 5632: split(/:/, $tail); 5633: $crstype = &unescape($crstype); 5634: $action = &unescape($action); 5635: $ownername = &unescape($ownername); 5636: $ownerdomain = &unescape($ownerdomain); 5637: $fullname = &unescape($fullname); 5638: $title = &unescape($title); 5639: $code = &unescape($code); 5640: $accessstart = &unescape($accessstart); 5641: $accessend = &unescape($accessend); 5642: my $incoming = &Apache::lonnet::thaw_unescape($infohashref); 5643: my ($result,$outcome); 5644: eval { 5645: local($SIG{__DIE__})='DEFAULT'; 5646: my %rtnhash; 5647: $outcome = &localenroll::crsreq_updates($cdom,$cnum,$crstype,$action, 5648: $ownername,$ownerdomain,$fullname, 5649: $title,$code,$accessstart,$accessend, 5650: $incoming,\%rtnhash); 5651: if ($outcome eq 'ok') { 5652: my @posskeys = qw(createdweb createdmsg createdcustomized createdactions queuedweb queuedmsg formitems reviewweb validationjs onload javascript); 5653: foreach my $key (keys(%rtnhash)) { 5654: if (grep(/^\Q$key\E/,@posskeys)) { 5655: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rtnhash{$key}).'&'; 5656: } 5657: } 5658: $result =~ s/\&$//; 5659: } 5660: }; 5661: if (!$@) { 5662: if ($outcome eq 'ok') { 5663: &Reply($client, \$result, $userinput); 5664: } else { 5665: &Reply($client, "format_error\n", $userinput); 5666: } 5667: } else { 5668: &Failure($client,"unknown_cmd\n",$userinput); 5669: } 5670: return 1; 5671: } 5672: &register_handler("autocrsrequpdate", \&crsreq_update_handler, 0, 1, 0); 5673: 5674: # 5675: # Read and retrieve institutional code format (for support form). 5676: # Formal Parameters: 5677: # $cmd - Command that dispatched us. 5678: # $tail - Tail of the command. In this case it conatins 5679: # the course domain and the coursename. 5680: # $client - Socket open on the client. 5681: # Returns: 5682: # 1 - Continue processing. 5683: # 5684: sub get_institutional_code_format_handler { 5685: my ($cmd, $tail, $client) = @_; 5686: my $userinput = "$cmd:$tail"; 5687: 5688: my $reply; 5689: my($cdom,$course) = split(/:/,$tail); 5690: my @pairs = split/\&/,$course; 5691: my %instcodes = (); 5692: my %codes = (); 5693: my @codetitles = (); 5694: my %cat_titles = (); 5695: my %cat_order = (); 5696: foreach (@pairs) { 5697: my ($key,$value) = split/=/,$_; 5698: $instcodes{&unescape($key)} = &unescape($value); 5699: } 5700: my $formatreply = &localenroll::instcode_format($cdom, 5701: \%instcodes, 5702: \%codes, 5703: \@codetitles, 5704: \%cat_titles, 5705: \%cat_order); 5706: if ($formatreply eq 'ok') { 5707: my $codes_str = &Apache::lonnet::hash2str(%codes); 5708: my $codetitles_str = &Apache::lonnet::array2str(@codetitles); 5709: my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles); 5710: my $cat_order_str = &Apache::lonnet::hash2str(%cat_order); 5711: &Reply($client, 5712: $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':' 5713: .$cat_order_str."\n", 5714: $userinput); 5715: } else { 5716: # this else branch added by RF since if not ok, lonc will 5717: # hang waiting on reply until timeout. 5718: # 5719: &Reply($client, "format_error\n", $userinput); 5720: } 5721: 5722: return 1; 5723: } 5724: &register_handler("autoinstcodeformat", 5725: \&get_institutional_code_format_handler,0,1,0); 5726: 5727: sub get_institutional_defaults_handler { 5728: my ($cmd, $tail, $client) = @_; 5729: my $userinput = "$cmd:$tail"; 5730: 5731: my $dom = $tail; 5732: my %defaults_hash; 5733: my @code_order; 5734: my $outcome; 5735: eval { 5736: local($SIG{__DIE__})='DEFAULT'; 5737: $outcome = &localenroll::instcode_defaults($dom,\%defaults_hash, 5738: \@code_order); 5739: }; 5740: if (!$@) { 5741: if ($outcome eq 'ok') { 5742: my $result=''; 5743: while (my ($key,$value) = each(%defaults_hash)) { 5744: $result.=&escape($key).'='.&escape($value).'&'; 5745: } 5746: $result .= 'code_order='.&escape(join('&',@code_order)); 5747: &Reply($client,\$result,$userinput); 5748: } else { 5749: &Reply($client,"error\n", $userinput); 5750: } 5751: } else { 5752: &Failure($client,"unknown_cmd\n",$userinput); 5753: } 5754: } 5755: &register_handler("autoinstcodedefaults", 5756: \&get_institutional_defaults_handler,0,1,0); 5757: 5758: sub get_possible_instcodes_handler { 5759: my ($cmd, $tail, $client) = @_; 5760: my $userinput = "$cmd:$tail"; 5761: 5762: my $reply; 5763: my $cdom = $tail; 5764: my (@codetitles,%cat_titles,%cat_order,@code_order); 5765: my $formatreply = &localenroll::possible_instcodes($cdom, 5766: \@codetitles, 5767: \%cat_titles, 5768: \%cat_order, 5769: \@code_order); 5770: if ($formatreply eq 'ok') { 5771: my $result = join('&',map {&escape($_);} (@codetitles)).':'; 5772: $result .= join('&',map {&escape($_);} (@code_order)).':'; 5773: foreach my $key (keys(%cat_titles)) { 5774: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_titles{$key}).'&'; 5775: } 5776: $result =~ s/\&$//; 5777: $result .= ':'; 5778: foreach my $key (keys(%cat_order)) { 5779: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_order{$key}).'&'; 5780: } 5781: $result =~ s/\&$//; 5782: &Reply($client,\$result,$userinput); 5783: } else { 5784: &Reply($client, "format_error\n", $userinput); 5785: } 5786: return 1; 5787: } 5788: &register_handler("autopossibleinstcodes", 5789: \&get_possible_instcodes_handler,0,1,0); 5790: 5791: sub get_institutional_user_rules { 5792: my ($cmd, $tail, $client) = @_; 5793: my $userinput = "$cmd:$tail"; 5794: my $dom = &unescape($tail); 5795: my (%rules_hash,@rules_order); 5796: my $outcome; 5797: eval { 5798: local($SIG{__DIE__})='DEFAULT'; 5799: $outcome = &localenroll::username_rules($dom,\%rules_hash,\@rules_order); 5800: }; 5801: if (!$@) { 5802: if ($outcome eq 'ok') { 5803: my $result; 5804: foreach my $key (keys(%rules_hash)) { 5805: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&'; 5806: } 5807: $result =~ s/\&$//; 5808: $result .= ':'; 5809: if (@rules_order > 0) { 5810: foreach my $item (@rules_order) { 5811: $result .= &escape($item).'&'; 5812: } 5813: } 5814: $result =~ s/\&$//; 5815: &Reply($client,\$result,$userinput); 5816: } else { 5817: &Reply($client,"error\n", $userinput); 5818: } 5819: } else { 5820: &Failure($client,"unknown_cmd\n",$userinput); 5821: } 5822: } 5823: &register_handler("instuserrules",\&get_institutional_user_rules,0,1,0); 5824: 5825: sub get_institutional_id_rules { 5826: my ($cmd, $tail, $client) = @_; 5827: my $userinput = "$cmd:$tail"; 5828: my $dom = &unescape($tail); 5829: my (%rules_hash,@rules_order); 5830: my $outcome; 5831: eval { 5832: local($SIG{__DIE__})='DEFAULT'; 5833: $outcome = &localenroll::id_rules($dom,\%rules_hash,\@rules_order); 5834: }; 5835: if (!$@) { 5836: if ($outcome eq 'ok') { 5837: my $result; 5838: foreach my $key (keys(%rules_hash)) { 5839: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&'; 5840: } 5841: $result =~ s/\&$//; 5842: $result .= ':'; 5843: if (@rules_order > 0) { 5844: foreach my $item (@rules_order) { 5845: $result .= &escape($item).'&'; 5846: } 5847: } 5848: $result =~ s/\&$//; 5849: &Reply($client,\$result,$userinput); 5850: } else { 5851: &Reply($client,"error\n", $userinput); 5852: } 5853: } else { 5854: &Failure($client,"unknown_cmd\n",$userinput); 5855: } 5856: } 5857: &register_handler("instidrules",\&get_institutional_id_rules,0,1,0); 5858: 5859: sub get_institutional_selfcreate_rules { 5860: my ($cmd, $tail, $client) = @_; 5861: my $userinput = "$cmd:$tail"; 5862: my $dom = &unescape($tail); 5863: my (%rules_hash,@rules_order); 5864: my $outcome; 5865: eval { 5866: local($SIG{__DIE__})='DEFAULT'; 5867: $outcome = &localenroll::selfcreate_rules($dom,\%rules_hash,\@rules_order); 5868: }; 5869: if (!$@) { 5870: if ($outcome eq 'ok') { 5871: my $result; 5872: foreach my $key (keys(%rules_hash)) { 5873: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&'; 5874: } 5875: $result =~ s/\&$//; 5876: $result .= ':'; 5877: if (@rules_order > 0) { 5878: foreach my $item (@rules_order) { 5879: $result .= &escape($item).'&'; 5880: } 5881: } 5882: $result =~ s/\&$//; 5883: &Reply($client,\$result,$userinput); 5884: } else { 5885: &Reply($client,"error\n", $userinput); 5886: } 5887: } else { 5888: &Failure($client,"unknown_cmd\n",$userinput); 5889: } 5890: } 5891: &register_handler("instemailrules",\&get_institutional_selfcreate_rules,0,1,0); 5892: 5893: 5894: sub institutional_username_check { 5895: my ($cmd, $tail, $client) = @_; 5896: my $userinput = "$cmd:$tail"; 5897: my %rulecheck; 5898: my $outcome; 5899: my ($udom,$uname,@rules) = split(/:/,$tail); 5900: $udom = &unescape($udom); 5901: $uname = &unescape($uname); 5902: @rules = map {&unescape($_);} (@rules); 5903: eval { 5904: local($SIG{__DIE__})='DEFAULT'; 5905: $outcome = &localenroll::username_check($udom,$uname,\@rules,\%rulecheck); 5906: }; 5907: if (!$@) { 5908: if ($outcome eq 'ok') { 5909: my $result=''; 5910: foreach my $key (keys(%rulecheck)) { 5911: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&'; 5912: } 5913: &Reply($client,\$result,$userinput); 5914: } else { 5915: &Reply($client,"error\n", $userinput); 5916: } 5917: } else { 5918: &Failure($client,"unknown_cmd\n",$userinput); 5919: } 5920: } 5921: &register_handler("instrulecheck",\&institutional_username_check,0,1,0); 5922: 5923: sub institutional_id_check { 5924: my ($cmd, $tail, $client) = @_; 5925: my $userinput = "$cmd:$tail"; 5926: my %rulecheck; 5927: my $outcome; 5928: my ($udom,$id,@rules) = split(/:/,$tail); 5929: $udom = &unescape($udom); 5930: $id = &unescape($id); 5931: @rules = map {&unescape($_);} (@rules); 5932: eval { 5933: local($SIG{__DIE__})='DEFAULT'; 5934: $outcome = &localenroll::id_check($udom,$id,\@rules,\%rulecheck); 5935: }; 5936: if (!$@) { 5937: if ($outcome eq 'ok') { 5938: my $result=''; 5939: foreach my $key (keys(%rulecheck)) { 5940: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&'; 5941: } 5942: &Reply($client,\$result,$userinput); 5943: } else { 5944: &Reply($client,"error\n", $userinput); 5945: } 5946: } else { 5947: &Failure($client,"unknown_cmd\n",$userinput); 5948: } 5949: } 5950: &register_handler("instidrulecheck",\&institutional_id_check,0,1,0); 5951: 5952: sub institutional_selfcreate_check { 5953: my ($cmd, $tail, $client) = @_; 5954: my $userinput = "$cmd:$tail"; 5955: my %rulecheck; 5956: my $outcome; 5957: my ($udom,$email,@rules) = split(/:/,$tail); 5958: $udom = &unescape($udom); 5959: $email = &unescape($email); 5960: @rules = map {&unescape($_);} (@rules); 5961: eval { 5962: local($SIG{__DIE__})='DEFAULT'; 5963: $outcome = &localenroll::selfcreate_check($udom,$email,\@rules,\%rulecheck); 5964: }; 5965: if (!$@) { 5966: if ($outcome eq 'ok') { 5967: my $result=''; 5968: foreach my $key (keys(%rulecheck)) { 5969: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&'; 5970: } 5971: &Reply($client,\$result,$userinput); 5972: } else { 5973: &Reply($client,"error\n", $userinput); 5974: } 5975: } else { 5976: &Failure($client,"unknown_cmd\n",$userinput); 5977: } 5978: } 5979: &register_handler("instselfcreatecheck",\&institutional_selfcreate_check,0,1,0); 5980: 5981: # Get domain specific conditions for import of student photographs to a course 5982: # 5983: # Retrieves information from photo_permission subroutine in localenroll. 5984: # Returns outcome (ok) if no processing errors, and whether course owner is 5985: # required to accept conditions of use (yes/no). 5986: # 5987: # 5988: sub photo_permission_handler { 5989: my ($cmd, $tail, $client) = @_; 5990: my $userinput = "$cmd:$tail"; 5991: my $cdom = $tail; 5992: my ($perm_reqd,$conditions); 5993: my $outcome; 5994: eval { 5995: local($SIG{__DIE__})='DEFAULT'; 5996: $outcome = &localenroll::photo_permission($cdom,\$perm_reqd, 5997: \$conditions); 5998: }; 5999: if (!$@) { 6000: &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n", 6001: $userinput); 6002: } else { 6003: &Failure($client,"unknown_cmd\n",$userinput); 6004: } 6005: return 1; 6006: } 6007: &register_handler("autophotopermission",\&photo_permission_handler,0,1,0); 6008: 6009: # 6010: # Checks if student photo is available for a user in the domain, in the user's 6011: # directory (in /userfiles/internal/studentphoto.jpg). 6012: # Uses localstudentphoto:fetch() to ensure there is an up to date copy of 6013: # the student's photo. 6014: 6015: sub photo_check_handler { 6016: my ($cmd, $tail, $client) = @_; 6017: my $userinput = "$cmd:$tail"; 6018: my ($udom,$uname,$pid) = split(/:/,$tail); 6019: $udom = &unescape($udom); 6020: $uname = &unescape($uname); 6021: $pid = &unescape($pid); 6022: my $path=&propath($udom,$uname).'/userfiles/internal/'; 6023: if (!-e $path) { 6024: &mkpath($path); 6025: } 6026: my $response; 6027: my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response); 6028: $result .= ':'.$response; 6029: &Reply($client, &escape($result)."\n",$userinput); 6030: return 1; 6031: } 6032: &register_handler("autophotocheck",\&photo_check_handler,0,1,0); 6033: 6034: # 6035: # Retrieve information from localenroll about whether to provide a button 6036: # for users who have enbled import of student photos to initiate an 6037: # update of photo files for registered students. Also include 6038: # comment to display alongside button. 6039: 6040: sub photo_choice_handler { 6041: my ($cmd, $tail, $client) = @_; 6042: my $userinput = "$cmd:$tail"; 6043: my $cdom = &unescape($tail); 6044: my ($update,$comment); 6045: eval { 6046: local($SIG{__DIE__})='DEFAULT'; 6047: ($update,$comment) = &localenroll::manager_photo_update($cdom); 6048: }; 6049: if (!$@) { 6050: &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput); 6051: } else { 6052: &Failure($client,"unknown_cmd\n",$userinput); 6053: } 6054: return 1; 6055: } 6056: &register_handler("autophotochoice",\&photo_choice_handler,0,1,0); 6057: 6058: # 6059: # Gets a student's photo to exist (in the correct image type) in the user's 6060: # directory. 6061: # Formal Parameters: 6062: # $cmd - The command request that got us dispatched. 6063: # $tail - A colon separated set of words that will be split into: 6064: # $domain - student's domain 6065: # $uname - student username 6066: # $type - image type desired 6067: # $client - The socket open on the client. 6068: # Returns: 6069: # 1 - continue processing. 6070: 6071: sub student_photo_handler { 6072: my ($cmd, $tail, $client) = @_; 6073: my ($domain,$uname,$ext,$type) = split(/:/, $tail); 6074: 6075: my $path=&propath($domain,$uname). '/userfiles/internal/'; 6076: my $filename = 'studentphoto.'.$ext; 6077: if ($type eq 'thumbnail') { 6078: $filename = 'studentphoto_tn.'.$ext; 6079: } 6080: if (-e $path.$filename) { 6081: &Reply($client,"ok\n","$cmd:$tail"); 6082: return 1; 6083: } 6084: &mkpath($path); 6085: my $file; 6086: if ($type eq 'thumbnail') { 6087: eval { 6088: local($SIG{__DIE__})='DEFAULT'; 6089: $file=&localstudentphoto::fetch_thumbnail($domain,$uname); 6090: }; 6091: } else { 6092: $file=&localstudentphoto::fetch($domain,$uname); 6093: } 6094: if (!$file) { 6095: &Failure($client,"unavailable\n","$cmd:$tail"); 6096: return 1; 6097: } 6098: if (!-e $path.$filename) { &convert_photo($file,$path.$filename); } 6099: if (-e $path.$filename) { 6100: &Reply($client,"ok\n","$cmd:$tail"); 6101: return 1; 6102: } 6103: &Failure($client,"unable_to_convert\n","$cmd:$tail"); 6104: return 1; 6105: } 6106: &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0); 6107: 6108: sub inst_usertypes_handler { 6109: my ($cmd, $domain, $client) = @_; 6110: my $res; 6111: my $userinput = $cmd.":".$domain; # For logging purposes. 6112: my (%typeshash,@order,$result); 6113: eval { 6114: local($SIG{__DIE__})='DEFAULT'; 6115: $result=&localenroll::inst_usertypes($domain,\%typeshash,\@order); 6116: }; 6117: if ($result eq 'ok') { 6118: if (keys(%typeshash) > 0) { 6119: foreach my $key (keys(%typeshash)) { 6120: $res.=&escape($key).'='.&escape($typeshash{$key}).'&'; 6121: } 6122: } 6123: $res=~s/\&$//; 6124: $res .= ':'; 6125: if (@order > 0) { 6126: foreach my $item (@order) { 6127: $res .= &escape($item).'&'; 6128: } 6129: } 6130: $res=~s/\&$//; 6131: } 6132: &Reply($client, \$res, $userinput); 6133: return 1; 6134: } 6135: &register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0); 6136: 6137: # mkpath makes all directories for a file, expects an absolute path with a 6138: # file or a trailing / if just a dir is passed 6139: # returns 1 on success 0 on failure 6140: sub mkpath { 6141: my ($file)=@_; 6142: my @parts=split(/\//,$file,-1); 6143: my $now=$parts[0].'/'.$parts[1].'/'.$parts[2]; 6144: for (my $i=3;$i<= ($#parts-1);$i++) { 6145: $now.='/'.$parts[$i]; 6146: if (!-e $now) { 6147: if (!mkdir($now,0770)) { return 0; } 6148: } 6149: } 6150: return 1; 6151: } 6152: 6153: #--------------------------------------------------------------- 6154: # 6155: # Getting, decoding and dispatching requests: 6156: # 6157: # 6158: # Get a Request: 6159: # Gets a Request message from the client. The transaction 6160: # is defined as a 'line' of text. We remove the new line 6161: # from the text line. 6162: # 6163: sub get_request { 6164: my $input = <$client>; 6165: chomp($input); 6166: 6167: &Debug("get_request: Request = $input\n"); 6168: 6169: &status('Processing '.$clientname.':'.$input); 6170: 6171: return $input; 6172: } 6173: #--------------------------------------------------------------- 6174: # 6175: # Process a request. This sub should shrink as each action 6176: # gets farmed out into a separat sub that is registered 6177: # with the dispatch hash. 6178: # 6179: # Parameters: 6180: # user_input - The request received from the client (lonc). 6181: # Returns: 6182: # true to keep processing, false if caller should exit. 6183: # 6184: sub process_request { 6185: my ($userinput) = @_; # Easier for now to break style than to 6186: # fix all the userinput -> user_input. 6187: my $wasenc = 0; # True if request was encrypted. 6188: # ------------------------------------------------------------ See if encrypted 6189: # for command 6190: # sethost:<server> 6191: # <command>:<args> 6192: # we just send it to the processor 6193: # for 6194: # sethost:<server>:<command>:<args> 6195: # we do the implict set host and then do the command 6196: if ($userinput =~ /^sethost:/) { 6197: (my $cmd,my $newid,$userinput) = split(':',$userinput,3); 6198: if (defined($userinput)) { 6199: &sethost("$cmd:$newid"); 6200: } else { 6201: $userinput = "$cmd:$newid"; 6202: } 6203: } 6204: 6205: if ($userinput =~ /^enc/) { 6206: $userinput = decipher($userinput); 6207: $wasenc=1; 6208: if(!$userinput) { # Cipher not defined. 6209: &Failure($client, "error: Encrypted data without negotated key\n"); 6210: return 0; 6211: } 6212: } 6213: Debug("process_request: $userinput\n"); 6214: 6215: # 6216: # The 'correct way' to add a command to lond is now to 6217: # write a sub to execute it and Add it to the command dispatch 6218: # hash via a call to register_handler.. The comments to that 6219: # sub should give you enough to go on to show how to do this 6220: # along with the examples that are building up as this code 6221: # is getting refactored. Until all branches of the 6222: # if/elseif monster below have been factored out into 6223: # separate procesor subs, if the dispatch hash is missing 6224: # the command keyword, we will fall through to the remainder 6225: # of the if/else chain below in order to keep this thing in 6226: # working order throughout the transmogrification. 6227: 6228: my ($command, $tail) = split(/:/, $userinput, 2); 6229: chomp($command); 6230: chomp($tail); 6231: $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet. 6232: $command =~ s/(\r)//; # And this too for parameterless commands. 6233: if(!$tail) { 6234: $tail =""; # defined but blank. 6235: } 6236: 6237: &Debug("Command received: $command, encoded = $wasenc"); 6238: 6239: if(defined $Dispatcher{$command}) { 6240: 6241: my $dispatch_info = $Dispatcher{$command}; 6242: my $handler = $$dispatch_info[0]; 6243: my $need_encode = $$dispatch_info[1]; 6244: my $client_types = $$dispatch_info[2]; 6245: Debug("Matched dispatch hash: mustencode: $need_encode " 6246: ."ClientType $client_types"); 6247: 6248: # Validate the request: 6249: 6250: my $ok = 1; 6251: my $requesterprivs = 0; 6252: if(&isClient()) { 6253: $requesterprivs |= $CLIENT_OK; 6254: } 6255: if(&isManager()) { 6256: $requesterprivs |= $MANAGER_OK; 6257: } 6258: if($need_encode && (!$wasenc)) { 6259: Debug("Must encode but wasn't: $need_encode $wasenc"); 6260: $ok = 0; 6261: } 6262: if(($client_types & $requesterprivs) == 0) { 6263: Debug("Client not privileged to do this operation"); 6264: $ok = 0; 6265: } 6266: 6267: if($ok) { 6268: Debug("Dispatching to handler $command $tail"); 6269: my $keep_going = &$handler($command, $tail, $client); 6270: return $keep_going; 6271: } else { 6272: Debug("Refusing to dispatch because client did not match requirements"); 6273: Failure($client, "refused\n", $userinput); 6274: return 1; 6275: } 6276: 6277: } 6278: 6279: print $client "unknown_cmd\n"; 6280: # -------------------------------------------------------------------- complete 6281: Debug("process_request - returning 1"); 6282: return 1; 6283: } 6284: # 6285: # Decipher encoded traffic 6286: # Parameters: 6287: # input - Encoded data. 6288: # Returns: 6289: # Decoded data or undef if encryption key was not yet negotiated. 6290: # Implicit input: 6291: # cipher - This global holds the negotiated encryption key. 6292: # 6293: sub decipher { 6294: my ($input) = @_; 6295: my $output = ''; 6296: 6297: 6298: if($cipher) { 6299: my($enc, $enclength, $encinput) = split(/:/, $input); 6300: for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) { 6301: $output .= 6302: $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16))); 6303: } 6304: return substr($output, 0, $enclength); 6305: } else { 6306: return undef; 6307: } 6308: } 6309: 6310: # 6311: # Register a command processor. This function is invoked to register a sub 6312: # to process a request. Once registered, the ProcessRequest sub can automatically 6313: # dispatch requests to an appropriate sub, and do the top level validity checking 6314: # as well: 6315: # - Is the keyword recognized. 6316: # - Is the proper client type attempting the request. 6317: # - Is the request encrypted if it has to be. 6318: # Parameters: 6319: # $request_name - Name of the request being registered. 6320: # This is the command request that will match 6321: # against the hash keywords to lookup the information 6322: # associated with the dispatch information. 6323: # $procedure - Reference to a sub to call to process the request. 6324: # All subs get called as follows: 6325: # Procedure($cmd, $tail, $replyfd, $key) 6326: # $cmd - the actual keyword that invoked us. 6327: # $tail - the tail of the request that invoked us. 6328: # $replyfd- File descriptor connected to the client 6329: # $must_encode - True if the request must be encoded to be good. 6330: # $client_ok - True if it's ok for a client to request this. 6331: # $manager_ok - True if it's ok for a manager to request this. 6332: # Side effects: 6333: # - On success, the Dispatcher hash has an entry added for the key $RequestName 6334: # - On failure, the program will die as it's a bad internal bug to try to 6335: # register a duplicate command handler. 6336: # 6337: sub register_handler { 6338: my ($request_name,$procedure,$must_encode, $client_ok,$manager_ok) = @_; 6339: 6340: # Don't allow duplication# 6341: 6342: if (defined $Dispatcher{$request_name}) { 6343: die "Attempting to define a duplicate request handler for $request_name\n"; 6344: } 6345: # Build the client type mask: 6346: 6347: my $client_type_mask = 0; 6348: if($client_ok) { 6349: $client_type_mask |= $CLIENT_OK; 6350: } 6351: if($manager_ok) { 6352: $client_type_mask |= $MANAGER_OK; 6353: } 6354: 6355: # Enter the hash: 6356: 6357: my @entry = ($procedure, $must_encode, $client_type_mask); 6358: 6359: $Dispatcher{$request_name} = \@entry; 6360: 6361: } 6362: 6363: 6364: #------------------------------------------------------------------ 6365: 6366: 6367: 6368: 6369: # 6370: # Convert an error return code from lcpasswd to a string value. 6371: # 6372: sub lcpasswdstrerror { 6373: my $ErrorCode = shift; 6374: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { 6375: return "lcpasswd Unrecognized error return value ".$ErrorCode; 6376: } else { 6377: return $passwderrors[$ErrorCode]; 6378: } 6379: } 6380: 6381: # grabs exception and records it to log before exiting 6382: sub catchexception { 6383: my ($error)=@_; 6384: $SIG{'QUIT'}='DEFAULT'; 6385: $SIG{__DIE__}='DEFAULT'; 6386: &status("Catching exception"); 6387: &logthis("CRITICAL: " 6388: ."ABNORMAL EXIT. Child $$ for server ".$perlvar{'lonHostID'}." died through " 6389: ."a crash with this error msg->[$error]"); 6390: &logthis('Famous last words: '.$status.' - '.$lastlog); 6391: if ($client) { print $client "error: $error\n"; } 6392: $server->close(); 6393: die($error); 6394: } 6395: sub timeout { 6396: &status("Handling Timeout"); 6397: &logthis("CRITICAL: TIME OUT ".$$.""); 6398: &catchexception('Timeout'); 6399: } 6400: # -------------------------------- Set signal handlers to record abnormal exits 6401: 6402: 6403: $SIG{'QUIT'}=\&catchexception; 6404: $SIG{__DIE__}=\&catchexception; 6405: 6406: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf 6407: &status("Read loncapa.conf and loncapa_apache.conf"); 6408: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); 6409: %perlvar=%{$perlvarref}; 6410: undef $perlvarref; 6411: 6412: # ----------------------------- Make sure this process is running from user=www 6413: my $wwwid=getpwnam('www'); 6414: if ($wwwid!=$<) { 6415: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 6416: my $subj="LON: $currenthostid User ID mismatch"; 6417: system("echo 'User ID mismatch. lond must be run as user www.' |\ 6418: mailto $emailto -s '$subj' > /dev/null"); 6419: exit 1; 6420: } 6421: 6422: # --------------------------------------------- Check if other instance running 6423: 6424: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; 6425: 6426: if (-e $pidfile) { 6427: my $lfh=IO::File->new("$pidfile"); 6428: my $pide=<$lfh>; 6429: chomp($pide); 6430: if (kill 0 => $pide) { die "already running"; } 6431: } 6432: 6433: # ------------------------------------------------------------- Read hosts file 6434: 6435: 6436: 6437: # establish SERVER socket, bind and listen. 6438: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'}, 6439: Type => SOCK_STREAM, 6440: Proto => 'tcp', 6441: ReuseAddr => 1, 6442: Listen => 10 ) 6443: or die "making socket: $@\n"; 6444: 6445: # --------------------------------------------------------- Do global variables 6446: 6447: # global variables 6448: 6449: my %children = (); # keys are current child process IDs 6450: 6451: sub REAPER { # takes care of dead children 6452: $SIG{CHLD} = \&REAPER; 6453: &status("Handling child death"); 6454: my $pid; 6455: do { 6456: $pid = waitpid(-1,&WNOHANG()); 6457: if (defined($children{$pid})) { 6458: &logthis("Child $pid died"); 6459: delete($children{$pid}); 6460: } elsif ($pid > 0) { 6461: &logthis("Unknown Child $pid died"); 6462: } 6463: } while ( $pid > 0 ); 6464: foreach my $child (keys(%children)) { 6465: $pid = waitpid($child,&WNOHANG()); 6466: if ($pid > 0) { 6467: &logthis("Child $child - $pid looks like we missed it's death"); 6468: delete($children{$pid}); 6469: } 6470: } 6471: &status("Finished Handling child death"); 6472: } 6473: 6474: sub HUNTSMAN { # signal handler for SIGINT 6475: &status("Killing children (INT)"); 6476: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 6477: kill 'INT' => keys %children; 6478: &logthis("Free socket: ".shutdown($server,2)); # free up socket 6479: my $execdir=$perlvar{'lonDaemons'}; 6480: unlink("$execdir/logs/lond.pid"); 6481: &logthis("CRITICAL: Shutting down"); 6482: &status("Done killing children"); 6483: exit; # clean up with dignity 6484: } 6485: 6486: sub HUPSMAN { # signal handler for SIGHUP 6487: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 6488: &status("Killing children for restart (HUP)"); 6489: kill 'INT' => keys %children; 6490: &logthis("Free socket: ".shutdown($server,2)); # free up socket 6491: &logthis("CRITICAL: Restarting"); 6492: my $execdir=$perlvar{'lonDaemons'}; 6493: unlink("$execdir/logs/lond.pid"); 6494: &status("Restarting self (HUP)"); 6495: exec("$execdir/lond"); # here we go again 6496: } 6497: 6498: # 6499: # Reload the Apache daemon's state. 6500: # This is done by invoking /home/httpd/perl/apachereload 6501: # a setuid perl script that can be root for us to do this job. 6502: # 6503: sub ReloadApache { 6504: # --------------------------- Handle case of another apachereload process (locking) 6505: if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) { 6506: my $execdir = $perlvar{'lonDaemons'}; 6507: my $script = $execdir."/apachereload"; 6508: system($script); 6509: unlink('/tmp/lock_apachereload'); # Remove the lock file. 6510: } 6511: } 6512: 6513: # 6514: # Called in response to a USR2 signal. 6515: # - Reread hosts.tab 6516: # - All children connected to hosts that were removed from hosts.tab 6517: # are killed via SIGINT 6518: # - All children connected to previously existing hosts are sent SIGUSR1 6519: # - Our internal hosts hash is updated to reflect the new contents of 6520: # hosts.tab causing connections from hosts added to hosts.tab to 6521: # now be honored. 6522: # 6523: sub UpdateHosts { 6524: &status("Reload hosts.tab"); 6525: logthis(' Updating connections '); 6526: # 6527: # The %children hash has the set of IP's we currently have children 6528: # on. These need to be matched against records in the hosts.tab 6529: # Any ip's no longer in the table get killed off they correspond to 6530: # either dropped or changed hosts. Note that the re-read of the table 6531: # will take care of new and changed hosts as connections come into being. 6532: 6533: &Apache::lonnet::reset_hosts_info(); 6534: 6535: foreach my $child (keys(%children)) { 6536: my $childip = $children{$child}; 6537: if ($childip ne '127.0.0.1' 6538: && !defined(&Apache::lonnet::get_hosts_from_ip($childip))) { 6539: logthis(' UpdateHosts killing child ' 6540: ." $child for ip $childip "); 6541: kill('INT', $child); 6542: } else { 6543: logthis(' keeping child for ip ' 6544: ." $childip (pid=$child) "); 6545: } 6546: } 6547: ReloadApache; 6548: &status("Finished reloading hosts.tab"); 6549: } 6550: 6551: 6552: sub checkchildren { 6553: &status("Checking on the children (sending signals)"); 6554: &initnewstatus(); 6555: &logstatus(); 6556: &logthis('Going to check on the children'); 6557: my $docdir=$perlvar{'lonDocRoot'}; 6558: foreach (sort keys %children) { 6559: #sleep 1; 6560: unless (kill 'USR1' => $_) { 6561: &logthis ('Child '.$_.' is dead'); 6562: &logstatus($$.' is dead'); 6563: delete($children{$_}); 6564: } 6565: } 6566: sleep 5; 6567: $SIG{ALRM} = sub { Debug("timeout"); 6568: die "timeout"; }; 6569: $SIG{__DIE__} = 'DEFAULT'; 6570: &status("Checking on the children (waiting for reports)"); 6571: foreach (sort keys %children) { 6572: unless (-e "$docdir/lon-status/londchld/$_.txt") { 6573: eval { 6574: alarm(300); 6575: &logthis('Child '.$_.' did not respond'); 6576: kill 9 => $_; 6577: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 6578: #$subj="LON: $currenthostid killed lond process $_"; 6579: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; 6580: #$execdir=$perlvar{'lonDaemons'}; 6581: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; 6582: delete($children{$_}); 6583: alarm(0); 6584: } 6585: } 6586: } 6587: $SIG{ALRM} = 'DEFAULT'; 6588: $SIG{__DIE__} = \&catchexception; 6589: &status("Finished checking children"); 6590: &logthis('Finished Checking children'); 6591: } 6592: 6593: # --------------------------------------------------------------------- Logging 6594: 6595: sub logthis { 6596: my $message=shift; 6597: my $execdir=$perlvar{'lonDaemons'}; 6598: my $fh=IO::File->new(">>$execdir/logs/lond.log"); 6599: my $now=time; 6600: my $local=localtime($now); 6601: $lastlog=$local.': '.$message; 6602: print $fh "$local ($$): $message\n"; 6603: } 6604: 6605: # ------------------------- Conditional log if $DEBUG true. 6606: sub Debug { 6607: my $message = shift; 6608: if($DEBUG) { 6609: &logthis($message); 6610: } 6611: } 6612: 6613: # 6614: # Sub to do replies to client.. this gives a hook for some 6615: # debug tracing too: 6616: # Parameters: 6617: # fd - File open on client. 6618: # reply - Text to send to client. 6619: # request - Original request from client. 6620: # 6621: #NOTE $reply must be terminated by exactly *one* \n. If $reply is a reference 6622: #this is done automatically ($$reply must not contain any \n in this case). 6623: #If $reply is a string the caller has to ensure this. 6624: sub Reply { 6625: my ($fd, $reply, $request) = @_; 6626: if (ref($reply)) { 6627: print $fd $$reply; 6628: print $fd "\n"; 6629: if ($DEBUG) { Debug("Request was $request Reply was $$reply"); } 6630: } else { 6631: print $fd $reply; 6632: if ($DEBUG) { Debug("Request was $request Reply was $reply"); } 6633: } 6634: $Transactions++; 6635: } 6636: 6637: 6638: # 6639: # Sub to report a failure. 6640: # This function: 6641: # - Increments the failure statistic counters. 6642: # - Invokes Reply to send the error message to the client. 6643: # Parameters: 6644: # fd - File descriptor open on the client 6645: # reply - Reply text to emit. 6646: # request - The original request message (used by Reply 6647: # to debug if that's enabled. 6648: # Implicit outputs: 6649: # $Failures- The number of failures is incremented. 6650: # Reply (invoked here) sends a message to the 6651: # client: 6652: # 6653: sub Failure { 6654: my $fd = shift; 6655: my $reply = shift; 6656: my $request = shift; 6657: 6658: $Failures++; 6659: Reply($fd, $reply, $request); # That's simple eh? 6660: } 6661: # ------------------------------------------------------------------ Log status 6662: 6663: sub logstatus { 6664: &status("Doing logging"); 6665: my $docdir=$perlvar{'lonDocRoot'}; 6666: { 6667: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); 6668: print $fh $status."\n".$lastlog."\n".time."\n$keymode"; 6669: $fh->close(); 6670: } 6671: &status("Finished $$.txt"); 6672: { 6673: open(LOG,">>$docdir/lon-status/londstatus.txt"); 6674: flock(LOG,LOCK_EX); 6675: print LOG $$."\t".$clientname."\t".$currenthostid."\t" 6676: .$status."\t".$lastlog."\t $keymode\n"; 6677: flock(LOG,LOCK_UN); 6678: close(LOG); 6679: } 6680: &status("Finished logging"); 6681: } 6682: 6683: sub initnewstatus { 6684: my $docdir=$perlvar{'lonDocRoot'}; 6685: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); 6686: my $now=time(); 6687: my $local=localtime($now); 6688: print $fh "LOND status $local - parent $$\n\n"; 6689: opendir(DIR,"$docdir/lon-status/londchld"); 6690: while (my $filename=readdir(DIR)) { 6691: unlink("$docdir/lon-status/londchld/$filename"); 6692: } 6693: closedir(DIR); 6694: } 6695: 6696: # -------------------------------------------------------------- Status setting 6697: 6698: sub status { 6699: my $what=shift; 6700: my $now=time; 6701: my $local=localtime($now); 6702: $status=$local.': '.$what; 6703: $0='lond: '.$what.' '.$local; 6704: } 6705: 6706: # -------------------------------------------------------------- Talk to lonsql 6707: 6708: sub sql_reply { 6709: my ($cmd)=@_; 6710: my $answer=&sub_sql_reply($cmd); 6711: if ($answer eq 'con_lost') { $answer=&sub_sql_reply($cmd); } 6712: return $answer; 6713: } 6714: 6715: sub sub_sql_reply { 6716: my ($cmd)=@_; 6717: my $unixsock="mysqlsock"; 6718: my $peerfile="$perlvar{'lonSockDir'}/$unixsock"; 6719: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 6720: Type => SOCK_STREAM, 6721: Timeout => 10) 6722: or return "con_lost"; 6723: print $sclient "$cmd:$currentdomainid\n"; 6724: my $answer=<$sclient>; 6725: chomp($answer); 6726: if (!$answer) { $answer="con_lost"; } 6727: return $answer; 6728: } 6729: 6730: # --------------------------------------- Is this the home server of an author? 6731: 6732: sub ishome { 6733: my $author=shift; 6734: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 6735: my ($udom,$uname)=split(/\//,$author); 6736: my $proname=propath($udom,$uname); 6737: if (-e $proname) { 6738: return 'owner'; 6739: } else { 6740: return 'not_owner'; 6741: } 6742: } 6743: 6744: # ======================================================= Continue main program 6745: # ---------------------------------------------------- Fork once and dissociate 6746: 6747: my $fpid=fork; 6748: exit if $fpid; 6749: die "Couldn't fork: $!" unless defined ($fpid); 6750: 6751: POSIX::setsid() or die "Can't start new session: $!"; 6752: 6753: # ------------------------------------------------------- Write our PID on disk 6754: 6755: my $execdir=$perlvar{'lonDaemons'}; 6756: open (PIDSAVE,">$execdir/logs/lond.pid"); 6757: print PIDSAVE "$$\n"; 6758: close(PIDSAVE); 6759: &logthis("CRITICAL: ---------- Starting ----------"); 6760: &status('Starting'); 6761: 6762: 6763: 6764: # ----------------------------------------------------- Install signal handlers 6765: 6766: 6767: $SIG{CHLD} = \&REAPER; 6768: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 6769: $SIG{HUP} = \&HUPSMAN; 6770: $SIG{USR1} = \&checkchildren; 6771: $SIG{USR2} = \&UpdateHosts; 6772: 6773: # Read the host hashes: 6774: &Apache::lonnet::load_hosts_tab(); 6775: my %iphost = &Apache::lonnet::get_iphost(1); 6776: 6777: $dist=`$perlvar{'lonDaemons'}/distprobe`; 6778: 6779: my $arch = `uname -i`; 6780: chomp($arch); 6781: if ($arch eq 'unknown') { 6782: $arch = `uname -m`; 6783: chomp($arch); 6784: } 6785: 6786: # -------------------------------------------------------------- 6787: # Accept connections. When a connection comes in, it is validated 6788: # and if good, a child process is created to process transactions 6789: # along the connection. 6790: 6791: while (1) { 6792: &status('Starting accept'); 6793: $client = $server->accept() or next; 6794: &status('Accepted '.$client.' off to spawn'); 6795: make_new_child($client); 6796: &status('Finished spawning'); 6797: } 6798: 6799: sub make_new_child { 6800: my $pid; 6801: # my $cipher; # Now global 6802: my $sigset; 6803: 6804: $client = shift; 6805: &status('Starting new child '.$client); 6806: &logthis(' Attempting to start child ('.$client. 6807: ")"); 6808: # block signal for fork 6809: $sigset = POSIX::SigSet->new(SIGINT); 6810: sigprocmask(SIG_BLOCK, $sigset) 6811: or die "Can't block SIGINT for fork: $!\n"; 6812: 6813: die "fork: $!" unless defined ($pid = fork); 6814: 6815: $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of 6816: # connection liveness. 6817: 6818: # 6819: # Figure out who we're talking to so we can record the peer in 6820: # the pid hash. 6821: # 6822: my $caller = getpeername($client); 6823: my ($port,$iaddr); 6824: if (defined($caller) && length($caller) > 0) { 6825: ($port,$iaddr)=unpack_sockaddr_in($caller); 6826: } else { 6827: &logthis("Unable to determine who caller was, getpeername returned nothing"); 6828: } 6829: if (defined($iaddr)) { 6830: $clientip = inet_ntoa($iaddr); 6831: Debug("Connected with $clientip"); 6832: } else { 6833: &logthis("Unable to determine clientip"); 6834: $clientip='Unavailable'; 6835: } 6836: 6837: if ($pid) { 6838: # Parent records the child's birth and returns. 6839: sigprocmask(SIG_UNBLOCK, $sigset) 6840: or die "Can't unblock SIGINT for fork: $!\n"; 6841: $children{$pid} = $clientip; 6842: &status('Started child '.$pid); 6843: close($client); 6844: return; 6845: } else { 6846: # Child can *not* return from this subroutine. 6847: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before 6848: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns 6849: #don't get intercepted 6850: $SIG{USR1}= \&logstatus; 6851: $SIG{ALRM}= \&timeout; 6852: # 6853: # Block sigpipe as it gets thrownon socket disconnect and we want to 6854: # deal with that as a read faiure instead. 6855: # 6856: my $blockset = POSIX::SigSet->new(SIGPIPE); 6857: sigprocmask(SIG_BLOCK, $blockset); 6858: 6859: $lastlog='Forked '; 6860: $status='Forked'; 6861: 6862: # unblock signals 6863: sigprocmask(SIG_UNBLOCK, $sigset) 6864: or die "Can't unblock SIGINT for fork: $!\n"; 6865: 6866: # my $tmpsnum=0; # Now global 6867: #---------------------------------------------------- kerberos 5 initialization 6868: &Authen::Krb5::init_context(); 6869: 6870: my $no_ets; 6871: if ($dist =~ /^(?:centos|rhes|scientific)(\d+)$/) { 6872: if ($1 >= 7) { 6873: $no_ets = 1; 6874: } 6875: } elsif ($dist =~ /^suse(\d+\.\d+)$/) { 6876: if (($1 eq '9.3') || ($1 >= 12.2)) { 6877: $no_ets = 1; 6878: } 6879: } elsif ($dist =~ /^sles(\d+)$/) { 6880: if ($1 > 11) { 6881: $no_ets = 1; 6882: } 6883: } elsif ($dist =~ /^fedora(\d+)$/) { 6884: if ($1 < 7) { 6885: $no_ets = 1; 6886: } 6887: } 6888: unless ($no_ets) { 6889: &Authen::Krb5::init_ets(); 6890: } 6891: 6892: &status('Accepted connection'); 6893: # ============================================================================= 6894: # do something with the connection 6895: # ----------------------------------------------------------------------------- 6896: # see if we know client and 'check' for spoof IP by ineffective challenge 6897: 6898: my $outsideip=$clientip; 6899: if ($clientip eq '127.0.0.1') { 6900: $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'}); 6901: } 6902: &ReadManagerTable(); 6903: my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip)); 6904: my $ismanager=($managers{$outsideip} ne undef); 6905: $clientname = "[unknown]"; 6906: if($clientrec) { # Establish client type. 6907: $ConnectionType = "client"; 6908: $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1]; 6909: if($ismanager) { 6910: $ConnectionType = "both"; 6911: } 6912: } else { 6913: $ConnectionType = "manager"; 6914: $clientname = $managers{$outsideip}; 6915: } 6916: my $clientok; 6917: 6918: if ($clientrec || $ismanager) { 6919: &status("Waiting for init from $clientip $clientname"); 6920: &logthis('INFO: Connection, '. 6921: $clientip. 6922: " ($clientname) connection type = $ConnectionType " ); 6923: &status("Connecting $clientip ($clientname))"); 6924: my $remotereq=<$client>; 6925: chomp($remotereq); 6926: Debug("Got init: $remotereq"); 6927: 6928: if ($remotereq =~ /^init/) { 6929: &sethost("sethost:$perlvar{'lonHostID'}"); 6930: # 6931: # If the remote is attempting a local init... give that a try: 6932: # 6933: (my $i, my $inittype, $clientversion) = split(/:/, $remotereq); 6934: # For LON-CAPA 2.9, the client session will have sent its LON-CAPA 6935: # version when initiating the connection. For LON-CAPA 2.8 and older, 6936: # the version is retrieved from the global %loncaparevs in lonnet.pm. 6937: # $clientversion contains path to keyfile if $inittype eq 'local' 6938: # it's overridden below in this case 6939: $clientversion ||= $Apache::lonnet::loncaparevs{$clientname}; 6940: 6941: # If the connection type is ssl, but I didn't get my 6942: # certificate files yet, then I'll drop back to 6943: # insecure (if allowed). 6944: 6945: if($inittype eq "ssl") { 6946: my ($ca, $cert) = lonssl::CertificateFile; 6947: my $kfile = lonssl::KeyFile; 6948: if((!$ca) || 6949: (!$cert) || 6950: (!$kfile)) { 6951: $inittype = ""; # This forces insecure attempt. 6952: &logthis(" Certificates not " 6953: ."installed -- trying insecure auth"); 6954: } else { # SSL certificates are in place so 6955: } # Leave the inittype alone. 6956: } 6957: 6958: if($inittype eq "local") { 6959: $clientversion = $perlvar{'lonVersion'}; 6960: my $key = LocalConnection($client, $remotereq); 6961: if($key) { 6962: Debug("Got local key $key"); 6963: $clientok = 1; 6964: my $cipherkey = pack("H32", $key); 6965: $cipher = new IDEA($cipherkey); 6966: print $client "ok:local\n"; 6967: &logthis('' 6968: . "Successful local authentication "); 6969: $keymode = "local" 6970: } else { 6971: Debug("Failed to get local key"); 6972: $clientok = 0; 6973: shutdown($client, 3); 6974: close $client; 6975: } 6976: } elsif ($inittype eq "ssl") { 6977: my $key = SSLConnection($client); 6978: if ($key) { 6979: $clientok = 1; 6980: my $cipherkey = pack("H32", $key); 6981: $cipher = new IDEA($cipherkey); 6982: &logthis('' 6983: ."Successfull ssl authentication with $clientname "); 6984: $keymode = "ssl"; 6985: 6986: } else { 6987: $clientok = 0; 6988: close $client; 6989: } 6990: 6991: } else { 6992: my $ok = InsecureConnection($client); 6993: if($ok) { 6994: $clientok = 1; 6995: &logthis('' 6996: ."Successful insecure authentication with $clientname "); 6997: print $client "ok\n"; 6998: $keymode = "insecure"; 6999: } else { 7000: &logthis('' 7001: ."Attempted insecure connection disallowed "); 7002: close $client; 7003: $clientok = 0; 7004: 7005: } 7006: } 7007: } else { 7008: &logthis( 7009: "WARNING: " 7010: ."$clientip failed to initialize: >$remotereq< "); 7011: &status('No init '.$clientip); 7012: } 7013: 7014: } else { 7015: &logthis( 7016: "WARNING: Unknown client $clientip"); 7017: &status('Hung up on '.$clientip); 7018: } 7019: 7020: if ($clientok) { 7021: # ---------------- New known client connecting, could mean machine online again 7022: if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip 7023: && $clientip ne '127.0.0.1') { 7024: &Apache::lonnet::reconlonc($clientname); 7025: } 7026: &logthis("Established connection: $clientname"); 7027: &status('Will listen to '.$clientname); 7028: # ------------------------------------------------------------ Process requests 7029: my $keep_going = 1; 7030: my $user_input; 7031: my $clienthost = &Apache::lonnet::hostname($clientname); 7032: my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost); 7033: $clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID); 7034: while(($user_input = get_request) && $keep_going) { 7035: alarm(120); 7036: Debug("Main: Got $user_input\n"); 7037: $keep_going = &process_request($user_input); 7038: alarm(0); 7039: &status('Listening to '.$clientname." ($keymode)"); 7040: } 7041: 7042: # --------------------------------------------- client unknown or fishy, refuse 7043: } else { 7044: print $client "refused\n"; 7045: $client->close(); 7046: &logthis("WARNING: " 7047: ."Rejected client $clientip, closing connection"); 7048: } 7049: } 7050: 7051: # ============================================================================= 7052: 7053: &logthis("CRITICAL: " 7054: ."Disconnect from $clientip ($clientname)"); 7055: 7056: 7057: # this exit is VERY important, otherwise the child will become 7058: # a producer of more and more children, forking yourself into 7059: # process death. 7060: exit; 7061: 7062: } 7063: # 7064: # Determine if a user is an author for the indicated domain. 7065: # 7066: # Parameters: 7067: # domain - domain to check in . 7068: # user - Name of user to check. 7069: # 7070: # Return: 7071: # 1 - User is an author for domain. 7072: # 0 - User is not an author for domain. 7073: sub is_author { 7074: my ($domain, $user) = @_; 7075: 7076: &Debug("is_author: $user @ $domain"); 7077: 7078: my $hashref = &tie_user_hash($domain, $user, "roles", 7079: &GDBM_READER()); 7080: 7081: # Author role should show up as a key /domain/_au 7082: 7083: my $value; 7084: if ($hashref) { 7085: 7086: my $key = "/$domain/_au"; 7087: if (defined($hashref)) { 7088: $value = $hashref->{$key}; 7089: if(!untie_user_hash($hashref)) { 7090: return 'error: ' . ($!+0)." untie (GDBM) Failed"; 7091: } 7092: } 7093: 7094: if(defined($value)) { 7095: &Debug("$user @ $domain is an author"); 7096: } 7097: } else { 7098: return 'error: '.($!+0)." tie (GDBM) Failed"; 7099: } 7100: 7101: return defined($value); 7102: } 7103: # 7104: # Checks to see if the input roleput request was to set 7105: # an author role. If so, creates construction space 7106: # Parameters: 7107: # request - The request sent to the rolesput subchunk. 7108: # We're looking for /domain/_au 7109: # domain - The domain in which the user is having roles doctored. 7110: # user - Name of the user for which the role is being put. 7111: # authtype - The authentication type associated with the user. 7112: # 7113: sub manage_permissions { 7114: my ($request, $domain, $user, $authtype) = @_; 7115: # See if the request is of the form /$domain/_au 7116: if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput... 7117: my $path=$perlvar{'lonDocRoot'}."/priv/$domain"; 7118: unless (-e $path) { 7119: mkdir($path); 7120: } 7121: unless (-e $path.'/'.$user) { 7122: mkdir($path.'/'.$user); 7123: } 7124: } 7125: } 7126: 7127: 7128: # 7129: # Return the full path of a user password file, whether it exists or not. 7130: # Parameters: 7131: # domain - Domain in which the password file lives. 7132: # user - name of the user. 7133: # Returns: 7134: # Full passwd path: 7135: # 7136: sub password_path { 7137: my ($domain, $user) = @_; 7138: return &propath($domain, $user).'/passwd'; 7139: } 7140: 7141: # Password Filename 7142: # Returns the path to a passwd file given domain and user... only if 7143: # it exists. 7144: # Parameters: 7145: # domain - Domain in which to search. 7146: # user - username. 7147: # Returns: 7148: # - If the password file exists returns its path. 7149: # - If the password file does not exist, returns undefined. 7150: # 7151: sub password_filename { 7152: my ($domain, $user) = @_; 7153: 7154: Debug ("PasswordFilename called: dom = $domain user = $user"); 7155: 7156: my $path = &password_path($domain, $user); 7157: Debug("PasswordFilename got path: $path"); 7158: if(-e $path) { 7159: return $path; 7160: } else { 7161: return undef; 7162: } 7163: } 7164: 7165: # 7166: # Rewrite the contents of the user's passwd file. 7167: # Parameters: 7168: # domain - domain of the user. 7169: # name - User's name. 7170: # contents - New contents of the file. 7171: # Returns: 7172: # 0 - Failed. 7173: # 1 - Success. 7174: # 7175: sub rewrite_password_file { 7176: my ($domain, $user, $contents) = @_; 7177: 7178: my $file = &password_filename($domain, $user); 7179: if (defined $file) { 7180: my $pf = IO::File->new(">$file"); 7181: if($pf) { 7182: print $pf "$contents\n"; 7183: return 1; 7184: } else { 7185: return 0; 7186: } 7187: } else { 7188: return 0; 7189: } 7190: 7191: } 7192: 7193: # 7194: # get_auth_type - Determines the authorization type of a user in a domain. 7195: 7196: # Returns the authorization type or nouser if there is no such user. 7197: # 7198: sub get_auth_type { 7199: my ($domain, $user) = @_; 7200: 7201: Debug("get_auth_type( $domain, $user ) \n"); 7202: my $proname = &propath($domain, $user); 7203: my $passwdfile = "$proname/passwd"; 7204: if( -e $passwdfile ) { 7205: my $pf = IO::File->new($passwdfile); 7206: my $realpassword = <$pf>; 7207: chomp($realpassword); 7208: Debug("Password info = $realpassword\n"); 7209: my ($authtype, $contentpwd) = split(/:/, $realpassword); 7210: Debug("Authtype = $authtype, content = $contentpwd\n"); 7211: return "$authtype:$contentpwd"; 7212: } else { 7213: Debug("Returning nouser"); 7214: return "nouser"; 7215: } 7216: } 7217: 7218: # 7219: # Validate a user given their domain, name and password. This utility 7220: # function is used by both AuthenticateHandler and ChangePasswordHandler 7221: # to validate the login credentials of a user. 7222: # Parameters: 7223: # $domain - The domain being logged into (this is required due to 7224: # the capability for multihomed systems. 7225: # $user - The name of the user being validated. 7226: # $password - The user's propoposed password. 7227: # 7228: # Returns: 7229: # 1 - The domain,user,pasword triplet corresponds to a valid 7230: # user. 7231: # 0 - The domain,user,password triplet is not a valid user. 7232: # 7233: sub validate_user { 7234: my ($domain, $user, $password, $checkdefauth) = @_; 7235: 7236: # Why negative ~pi you may well ask? Well this function is about 7237: # authentication, and therefore very important to get right. 7238: # I've initialized the flag that determines whether or not I've 7239: # validated correctly to a value it's not supposed to get. 7240: # At the end of this function. I'll ensure that it's not still that 7241: # value so we don't just wind up returning some accidental value 7242: # as a result of executing an unforseen code path that 7243: # did not set $validated. At the end of valid execution paths, 7244: # validated shoule be 1 for success or 0 for failuer. 7245: 7246: my $validated = -3.14159; 7247: 7248: # How we authenticate is determined by the type of authentication 7249: # the user has been assigned. If the authentication type is 7250: # "nouser", the user does not exist so we will return 0. 7251: 7252: my $contents = &get_auth_type($domain, $user); 7253: my ($howpwd, $contentpwd) = split(/:/, $contents); 7254: 7255: my $null = pack("C",0); # Used by kerberos auth types. 7256: 7257: if ($howpwd eq 'nouser') { 7258: if ($checkdefauth) { 7259: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain); 7260: if ($domdefaults{'auth_def'} eq 'localauth') { 7261: $howpwd = $domdefaults{'auth_def'}; 7262: $contentpwd = $domdefaults{'auth_arg_def'}; 7263: } elsif ((($domdefaults{'auth_def'} eq 'krb4') || 7264: ($domdefaults{'auth_def'} eq 'krb5')) && 7265: ($domdefaults{'auth_arg_def'} ne '')) { 7266: $howpwd = $domdefaults{'auth_def'}; 7267: $contentpwd = $domdefaults{'auth_arg_def'}; 7268: } 7269: } 7270: } 7271: if ($howpwd ne 'nouser') { 7272: if($howpwd eq "internal") { # Encrypted is in local password file. 7273: if (length($contentpwd) == 13) { 7274: $validated = (crypt($password,$contentpwd) eq $contentpwd); 7275: if ($validated) { 7276: my $ncpass = &hash_passwd($domain,$password); 7277: if (&rewrite_password_file($domain,$user,"$howpwd:$ncpass")) { 7278: &update_passwd_history($user,$domain,$howpwd,'conversion'); 7279: &logthis("Validated password hashed with bcrypt for $user:$domain"); 7280: } 7281: } 7282: } else { 7283: $validated = &check_internal_passwd($password,$contentpwd,$domain); 7284: } 7285: } 7286: elsif ($howpwd eq "unix") { # User is a normal unix user. 7287: $contentpwd = (getpwnam($user))[1]; 7288: if($contentpwd) { 7289: if($contentpwd eq 'x') { # Shadow password file... 7290: my $pwauth_path = "/usr/local/sbin/pwauth"; 7291: open PWAUTH, "|$pwauth_path" or 7292: die "Cannot invoke authentication"; 7293: print PWAUTH "$user\n$password\n"; 7294: close PWAUTH; 7295: $validated = ! $?; 7296: 7297: } else { # Passwords in /etc/passwd. 7298: $validated = (crypt($password, 7299: $contentpwd) eq $contentpwd); 7300: } 7301: } else { 7302: $validated = 0; 7303: } 7304: } elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain. 7305: my $checkwithkrb5 = 0; 7306: if ($dist =~/^fedora(\d+)$/) { 7307: if ($1 > 11) { 7308: $checkwithkrb5 = 1; 7309: } 7310: } elsif ($dist =~ /^suse([\d.]+)$/) { 7311: if ($1 > 11.1) { 7312: $checkwithkrb5 = 1; 7313: } 7314: } 7315: if ($checkwithkrb5) { 7316: $validated = &krb5_authen($password,$null,$user,$contentpwd); 7317: } else { 7318: $validated = &krb4_authen($password,$null,$user,$contentpwd); 7319: } 7320: } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain. 7321: $validated = &krb5_authen($password,$null,$user,$contentpwd); 7322: } elsif ($howpwd eq "localauth") { 7323: # Authenticate via installation specific authentcation method: 7324: $validated = &localauth::localauth($user, 7325: $password, 7326: $contentpwd, 7327: $domain); 7328: if ($validated < 0) { 7329: &logthis("localauth for $contentpwd $user:$domain returned a $validated"); 7330: $validated = 0; 7331: } 7332: } else { # Unrecognized auth is also bad. 7333: $validated = 0; 7334: } 7335: } else { 7336: $validated = 0; 7337: } 7338: # 7339: # $validated has the correct stat of the authentication: 7340: # 7341: 7342: unless ($validated != -3.14159) { 7343: # I >really really< want to know if this happens. 7344: # since it indicates that user authentication is badly 7345: # broken in some code path. 7346: # 7347: die "ValidateUser - failed to set the value of validated $domain, $user $password"; 7348: } 7349: return $validated; 7350: } 7351: 7352: sub check_internal_passwd { 7353: my ($plainpass,$stored,$domain) = @_; 7354: my (undef,$method,@rest) = split(/!/,$stored); 7355: if ($method eq "bcrypt") { 7356: my $result = &hash_passwd($domain,$plainpass,@rest); 7357: if ($result ne $stored) { 7358: return 0; 7359: } 7360: # Upgrade to a larger number of rounds if necessary 7361: my $defaultcost; 7362: my %domconfig = 7363: &Apache::lonnet::get_dom('configuration',['password'],$domain); 7364: if (ref($domconfig{'password'}) eq 'HASH') { 7365: $defaultcost = $domconfig{'password'}{'cost'}; 7366: } 7367: if (($defaultcost eq '') || ($defaultcost =~ /D/)) { 7368: $defaultcost = 10; 7369: } 7370: return 1 unless($rest[0]<$defaultcost); 7371: } 7372: return 0; 7373: } 7374: 7375: sub get_last_authchg { 7376: my ($domain,$user) = @_; 7377: my $lastmod; 7378: my $logname = &propath($domain,$user).'/passwd.log'; 7379: if (-e "$logname") { 7380: $lastmod = (stat("$logname"))[9]; 7381: } 7382: return $lastmod; 7383: } 7384: 7385: sub krb4_authen { 7386: my ($password,$null,$user,$contentpwd) = @_; 7387: my $validated = 0; 7388: if (!($password =~ /$null/) ) { # Null password not allowed. 7389: eval { 7390: require Authen::Krb4; 7391: }; 7392: if (!$@) { 7393: my $k4error = &Authen::Krb4::get_pw_in_tkt($user, 7394: "", 7395: $contentpwd,, 7396: 'krbtgt', 7397: $contentpwd, 7398: 1, 7399: $password); 7400: if(!$k4error) { 7401: $validated = 1; 7402: } else { 7403: $validated = 0; 7404: &logthis('krb4: '.$user.', '.$contentpwd.', '. 7405: &Authen::Krb4::get_err_txt($Authen::Krb4::error)); 7406: } 7407: } else { 7408: $validated = krb5_authen($password,$null,$user,$contentpwd); 7409: } 7410: } 7411: return $validated; 7412: } 7413: 7414: sub krb5_authen { 7415: my ($password,$null,$user,$contentpwd) = @_; 7416: my $validated = 0; 7417: if(!($password =~ /$null/)) { # Null password not allowed. 7418: my $krbclient = &Authen::Krb5::parse_name($user.'@' 7419: .$contentpwd); 7420: my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd; 7421: my $krbserver = &Authen::Krb5::parse_name($krbservice); 7422: my $credentials= &Authen::Krb5::cc_default(); 7423: $credentials->initialize(&Authen::Krb5::parse_name($user.'@' 7424: .$contentpwd)); 7425: my $krbreturn; 7426: if (exists(&Authen::Krb5::get_init_creds_password)) { 7427: $krbreturn = 7428: &Authen::Krb5::get_init_creds_password($krbclient,$password, 7429: $krbservice); 7430: $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds'); 7431: } else { 7432: $krbreturn = 7433: &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver, 7434: $password,$credentials); 7435: $validated = ($krbreturn == 1); 7436: } 7437: if (!$validated) { 7438: &logthis('krb5: '.$user.', '.$contentpwd.', '. 7439: &Authen::Krb5::error()); 7440: } 7441: } 7442: return $validated; 7443: } 7444: 7445: sub addline { 7446: my ($fname,$hostid,$ip,$newline)=@_; 7447: my $contents; 7448: my $found=0; 7449: my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':'; 7450: my $sh; 7451: if ($sh=IO::File->new("$fname.subscription")) { 7452: while (my $subline=<$sh>) { 7453: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} 7454: } 7455: $sh->close(); 7456: } 7457: $sh=IO::File->new(">$fname.subscription"); 7458: if ($contents) { print $sh $contents; } 7459: if ($newline) { print $sh $newline; } 7460: $sh->close(); 7461: return $found; 7462: } 7463: 7464: sub get_chat { 7465: my ($cdom,$cname,$udom,$uname,$group)=@_; 7466: 7467: my @entries=(); 7468: my $namespace = 'nohist_chatroom'; 7469: my $namespace_inroom = 'nohist_inchatroom'; 7470: if ($group ne '') { 7471: $namespace .= '_'.$group; 7472: $namespace_inroom .= '_'.$group; 7473: } 7474: my $hashref = &tie_user_hash($cdom, $cname, $namespace, 7475: &GDBM_READER()); 7476: if ($hashref) { 7477: @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); 7478: &untie_user_hash($hashref); 7479: } 7480: my @participants=(); 7481: my $cutoff=time-60; 7482: $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom, 7483: &GDBM_WRCREAT()); 7484: if ($hashref) { 7485: $hashref->{$uname.':'.$udom}=time; 7486: foreach my $user (sort(keys(%$hashref))) { 7487: if ($hashref->{$user}>$cutoff) { 7488: push(@participants, 'active_participant:'.$user); 7489: } 7490: } 7491: &untie_user_hash($hashref); 7492: } 7493: return (@participants,@entries); 7494: } 7495: 7496: sub chat_add { 7497: my ($cdom,$cname,$newchat,$group)=@_; 7498: my @entries=(); 7499: my $time=time; 7500: my $namespace = 'nohist_chatroom'; 7501: my $logfile = 'chatroom.log'; 7502: if ($group ne '') { 7503: $namespace .= '_'.$group; 7504: $logfile = 'chatroom_'.$group.'.log'; 7505: } 7506: my $hashref = &tie_user_hash($cdom, $cname, $namespace, 7507: &GDBM_WRCREAT()); 7508: if ($hashref) { 7509: @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); 7510: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); 7511: my ($thentime,$idnum)=split(/\_/,$lastid); 7512: my $newid=$time.'_000000'; 7513: if ($thentime==$time) { 7514: $idnum=~s/^0+//; 7515: $idnum++; 7516: $idnum=substr('000000'.$idnum,-6,6); 7517: $newid=$time.'_'.$idnum; 7518: } 7519: $hashref->{$newid}=$newchat; 7520: my $expired=$time-3600; 7521: foreach my $comment (keys(%$hashref)) { 7522: my ($thistime) = ($comment=~/(\d+)\_/); 7523: if ($thistime<$expired) { 7524: delete $hashref->{$comment}; 7525: } 7526: } 7527: { 7528: my $proname=&propath($cdom,$cname); 7529: if (open(CHATLOG,">>$proname/$logfile")) { 7530: print CHATLOG ("$time:".&unescape($newchat)."\n"); 7531: } 7532: close(CHATLOG); 7533: } 7534: &untie_user_hash($hashref); 7535: } 7536: } 7537: 7538: sub unsub { 7539: my ($fname,$clientip)=@_; 7540: my $result; 7541: my $unsubs = 0; # Number of successful unsubscribes: 7542: 7543: 7544: # An old way subscriptions were handled was to have a 7545: # subscription marker file: 7546: 7547: Debug("Attempting unlink of $fname.$clientname"); 7548: if (unlink("$fname.$clientname")) { 7549: $unsubs++; # Successful unsub via marker file. 7550: } 7551: 7552: # The more modern way to do it is to have a subscription list 7553: # file: 7554: 7555: if (-e "$fname.subscription") { 7556: my $found=&addline($fname,$clientname,$clientip,''); 7557: if ($found) { 7558: $unsubs++; 7559: } 7560: } 7561: 7562: # If either or both of these mechanisms succeeded in unsubscribing a 7563: # resource we can return ok: 7564: 7565: if($unsubs) { 7566: $result = "ok\n"; 7567: } else { 7568: $result = "not_subscribed\n"; 7569: } 7570: 7571: return $result; 7572: } 7573: 7574: sub currentversion { 7575: my $fname=shift; 7576: my $version=-1; 7577: my $ulsdir=''; 7578: if ($fname=~/^(.+)\/[^\/]+$/) { 7579: $ulsdir=$1; 7580: } 7581: my ($fnamere1,$fnamere2); 7582: # remove version if already specified 7583: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; 7584: # get the bits that go before and after the version number 7585: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { 7586: $fnamere1=$1; 7587: $fnamere2='.'.$2; 7588: } 7589: if (-e $fname) { $version=1; } 7590: if (-e $ulsdir) { 7591: if(-d $ulsdir) { 7592: if (opendir(LSDIR,$ulsdir)) { 7593: my $ulsfn; 7594: while ($ulsfn=readdir(LSDIR)) { 7595: # see if this is a regular file (ignore links produced earlier) 7596: my $thisfile=$ulsdir.'/'.$ulsfn; 7597: unless (-l $thisfile) { 7598: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) { 7599: if ($1>$version) { $version=$1; } 7600: } 7601: } 7602: } 7603: closedir(LSDIR); 7604: $version++; 7605: } 7606: } 7607: } 7608: return $version; 7609: } 7610: 7611: sub thisversion { 7612: my $fname=shift; 7613: my $version=-1; 7614: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { 7615: $version=$1; 7616: } 7617: return $version; 7618: } 7619: 7620: sub subscribe { 7621: my ($userinput,$clientip)=@_; 7622: my $result; 7623: my ($cmd,$fname)=split(/:/,$userinput,2); 7624: my $ownership=&ishome($fname); 7625: if ($ownership eq 'owner') { 7626: # explitly asking for the current version? 7627: unless (-e $fname) { 7628: my $currentversion=&currentversion($fname); 7629: if (&thisversion($fname)==$currentversion) { 7630: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { 7631: my $root=$1; 7632: my $extension=$2; 7633: symlink($root.'.'.$extension, 7634: $root.'.'.$currentversion.'.'.$extension); 7635: unless ($extension=~/\.meta$/) { 7636: symlink($root.'.'.$extension.'.meta', 7637: $root.'.'.$currentversion.'.'.$extension.'.meta'); 7638: } 7639: } 7640: } 7641: } 7642: if (-e $fname) { 7643: if (-d $fname) { 7644: $result="directory\n"; 7645: } else { 7646: if (-e "$fname.$clientname") {&unsub($fname,$clientip);} 7647: my $now=time; 7648: my $found=&addline($fname,$clientname,$clientip, 7649: "$clientname:$clientip:$now\n"); 7650: if ($found) { $result="$fname\n"; } 7651: # if they were subscribed to only meta data, delete that 7652: # subscription, when you subscribe to a file you also get 7653: # the metadata 7654: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } 7655: $fname=~s/\/home\/httpd\/html\/res/raw/; 7656: my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}}; 7657: $protocol = 'http' if ($protocol ne 'https'); 7658: $fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname; 7659: $result="$fname\n"; 7660: } 7661: } else { 7662: $result="not_found\n"; 7663: } 7664: } else { 7665: $result="rejected\n"; 7666: } 7667: return $result; 7668: } 7669: # Change the passwd of a unix user. The caller must have 7670: # first verified that the user is a loncapa user. 7671: # 7672: # Parameters: 7673: # user - Unix user name to change. 7674: # pass - New password for the user. 7675: # Returns: 7676: # ok - if success 7677: # other - Some meaningfule error message string. 7678: # NOTE: 7679: # invokes a setuid script to change the passwd. 7680: sub change_unix_password { 7681: my ($user, $pass) = @_; 7682: 7683: &Debug("change_unix_password"); 7684: my $execdir=$perlvar{'lonDaemons'}; 7685: &Debug("Opening lcpasswd pipeline"); 7686: my $pf = IO::File->new("|$execdir/lcpasswd > " 7687: ."$perlvar{'lonDaemons'}" 7688: ."/logs/lcpasswd.log"); 7689: print $pf "$user\n$pass\n$pass\n"; 7690: close $pf; 7691: my $err = $?; 7692: return ($err < @passwderrors) ? $passwderrors[$err] : 7693: "pwchange_falure - unknown error"; 7694: 7695: 7696: } 7697: 7698: 7699: sub make_passwd_file { 7700: my ($uname,$udom,$umode,$npass,$passfilename,$action)=@_; 7701: my $result="ok"; 7702: if ($umode eq 'krb4' or $umode eq 'krb5') { 7703: { 7704: my $pf = IO::File->new(">$passfilename"); 7705: if ($pf) { 7706: print $pf "$umode:$npass\n"; 7707: &update_passwd_history($uname,$udom,$umode,$action); 7708: } else { 7709: $result = "pass_file_failed_error"; 7710: } 7711: } 7712: } elsif ($umode eq 'internal') { 7713: my $ncpass = &hash_passwd($udom,$npass); 7714: { 7715: &Debug("Creating internal auth"); 7716: my $pf = IO::File->new(">$passfilename"); 7717: if($pf) { 7718: print $pf "internal:$ncpass\n"; 7719: &update_passwd_history($uname,$udom,$umode,$action); 7720: } else { 7721: $result = "pass_file_failed_error"; 7722: } 7723: } 7724: } elsif ($umode eq 'localauth') { 7725: { 7726: my $pf = IO::File->new(">$passfilename"); 7727: if($pf) { 7728: print $pf "localauth:$npass\n"; 7729: } else { 7730: $result = "pass_file_failed_error"; 7731: } 7732: } 7733: } elsif ($umode eq 'unix') { 7734: &logthis(">>>Attempt to create unix account blocked -- unix auth not available for new users."); 7735: $result="no_new_unix_accounts"; 7736: } elsif ($umode eq 'none') { 7737: { 7738: my $pf = IO::File->new("> $passfilename"); 7739: if($pf) { 7740: print $pf "none:\n"; 7741: } else { 7742: $result = "pass_file_failed_error"; 7743: } 7744: } 7745: } else { 7746: $result="auth_mode_error"; 7747: } 7748: return $result; 7749: } 7750: 7751: sub convert_photo { 7752: my ($start,$dest)=@_; 7753: system("convert $start $dest"); 7754: } 7755: 7756: sub sethost { 7757: my ($remotereq) = @_; 7758: my (undef,$hostid)=split(/:/,$remotereq); 7759: # ignore sethost if we are already correct 7760: if ($hostid eq $currenthostid) { 7761: return 'ok'; 7762: } 7763: 7764: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } 7765: if (&Apache::lonnet::get_host_ip($perlvar{'lonHostID'}) 7766: eq &Apache::lonnet::get_host_ip($hostid)) { 7767: $currenthostid =$hostid; 7768: $currentdomainid=&Apache::lonnet::host_domain($hostid); 7769: # &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); 7770: } else { 7771: &logthis("Requested host id $hostid not an alias of ". 7772: $perlvar{'lonHostID'}." refusing connection"); 7773: return 'unable_to_set'; 7774: } 7775: return 'ok'; 7776: } 7777: 7778: sub version { 7779: my ($userinput)=@_; 7780: $remoteVERSION=(split(/:/,$userinput))[1]; 7781: return "version:$VERSION"; 7782: } 7783: 7784: sub get_usersession_config { 7785: my ($dom,$name) = @_; 7786: my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom); 7787: if (defined($cached)) { 7788: return $usersessionconf; 7789: } else { 7790: my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom); 7791: if (ref($domconfig{'usersessions'}) eq 'HASH') { 7792: &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600); 7793: return $domconfig{'usersessions'}; 7794: } 7795: } 7796: return; 7797: } 7798: 7799: 7800: 7801: 7802: sub distro_and_arch { 7803: return $dist.':'.$arch; 7804: } 7805: 7806: # ----------------------------------- POD (plain old documentation, CPAN style) 7807: 7808: =head1 NAME 7809: 7810: lond - "LON Daemon" Server (port "LOND" 5663) 7811: 7812: =head1 SYNOPSIS 7813: 7814: Usage: B<lond> 7815: 7816: Should only be run as user=www. This is a command-line script which 7817: is invoked by B<loncron>. There is no expectation that a typical user 7818: will manually start B<lond> from the command-line. (In other words, 7819: DO NOT START B<lond> YOURSELF.) 7820: 7821: =head1 DESCRIPTION 7822: 7823: There are two characteristics associated with the running of B<lond>, 7824: PROCESS MANAGEMENT (starting, stopping, handling child processes) 7825: and SERVER-SIDE ACTIVITIES (password authentication, user creation, 7826: subscriptions, etc). These are described in two large 7827: sections below. 7828: 7829: B<PROCESS MANAGEMENT> 7830: 7831: Preforker - server who forks first. Runs as a daemon. HUPs. 7832: Uses IDEA encryption 7833: 7834: B<lond> forks off children processes that correspond to the other servers 7835: in the network. Management of these processes can be done at the 7836: parent process level or the child process level. 7837: 7838: B<logs/lond.log> is the location of log messages. 7839: 7840: The process management is now explained in terms of linux shell commands, 7841: subroutines internal to this code, and signal assignments: 7842: 7843: =over 4 7844: 7845: =item * 7846: 7847: PID is stored in B<logs/lond.pid> 7848: 7849: This is the process id number of the parent B<lond> process. 7850: 7851: =item * 7852: 7853: SIGTERM and SIGINT 7854: 7855: Parent signal assignment: 7856: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 7857: 7858: Child signal assignment: 7859: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) 7860: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber 7861: to restart a new child.) 7862: 7863: Command-line invocations: 7864: B<kill> B<-s> SIGTERM I<PID> 7865: B<kill> B<-s> SIGINT I<PID> 7866: 7867: Subroutine B<HUNTSMAN>: 7868: This is only invoked for the B<lond> parent I<PID>. 7869: This kills all the children, and then the parent. 7870: The B<lonc.pid> file is cleared. 7871: 7872: =item * 7873: 7874: SIGHUP 7875: 7876: Current bug: 7877: This signal can only be processed the first time 7878: on the parent process. Subsequent SIGHUP signals 7879: have no effect. 7880: 7881: Parent signal assignment: 7882: $SIG{HUP} = \&HUPSMAN; 7883: 7884: Child signal assignment: 7885: none (nothing happens) 7886: 7887: Command-line invocations: 7888: B<kill> B<-s> SIGHUP I<PID> 7889: 7890: Subroutine B<HUPSMAN>: 7891: This is only invoked for the B<lond> parent I<PID>, 7892: This kills all the children, and then the parent. 7893: The B<lond.pid> file is cleared. 7894: 7895: =item * 7896: 7897: SIGUSR1 7898: 7899: Parent signal assignment: 7900: $SIG{USR1} = \&USRMAN; 7901: 7902: Child signal assignment: 7903: $SIG{USR1}= \&logstatus; 7904: 7905: Command-line invocations: 7906: B<kill> B<-s> SIGUSR1 I<PID> 7907: 7908: Subroutine B<USRMAN>: 7909: When invoked for the B<lond> parent I<PID>, 7910: SIGUSR1 is sent to all the children, and the status of 7911: each connection is logged. 7912: 7913: =item * 7914: 7915: SIGUSR2 7916: 7917: Parent Signal assignment: 7918: $SIG{USR2} = \&UpdateHosts 7919: 7920: Child signal assignment: 7921: NONE 7922: 7923: 7924: =item * 7925: 7926: SIGCHLD 7927: 7928: Parent signal assignment: 7929: $SIG{CHLD} = \&REAPER; 7930: 7931: Child signal assignment: 7932: none 7933: 7934: Command-line invocations: 7935: B<kill> B<-s> SIGCHLD I<PID> 7936: 7937: Subroutine B<REAPER>: 7938: This is only invoked for the B<lond> parent I<PID>. 7939: Information pertaining to the child is removed. 7940: The socket port is cleaned up. 7941: 7942: =back 7943: 7944: B<SERVER-SIDE ACTIVITIES> 7945: 7946: Server-side information can be accepted in an encrypted or non-encrypted 7947: method. 7948: 7949: =over 4 7950: 7951: =item ping 7952: 7953: Query a client in the hosts.tab table; "Are you there?" 7954: 7955: =item pong 7956: 7957: Respond to a ping query. 7958: 7959: =item ekey 7960: 7961: Read in encrypted key, make cipher. Respond with a buildkey. 7962: 7963: =item load 7964: 7965: Respond with CPU load based on a computation upon /proc/loadavg. 7966: 7967: =item currentauth 7968: 7969: Reply with current authentication information (only over an 7970: encrypted channel). 7971: 7972: =item auth 7973: 7974: Only over an encrypted channel, reply as to whether a user's 7975: authentication information can be validated. 7976: 7977: =item passwd 7978: 7979: Allow for a password to be set. 7980: 7981: =item makeuser 7982: 7983: Make a user. 7984: 7985: =item changeuserauth 7986: 7987: Allow for authentication mechanism and password to be changed. 7988: 7989: =item home 7990: 7991: Respond to a question "are you the home for a given user?" 7992: 7993: =item update 7994: 7995: Update contents of a subscribed resource. 7996: 7997: =item unsubscribe 7998: 7999: The server is unsubscribing from a resource. 8000: 8001: =item subscribe 8002: 8003: The server is subscribing to a resource. 8004: 8005: =item log 8006: 8007: Place in B<logs/lond.log> 8008: 8009: =item put 8010: 8011: stores hash in namespace 8012: 8013: =item rolesput 8014: 8015: put a role into a user's environment 8016: 8017: =item get 8018: 8019: returns hash with keys from array 8020: reference filled in from namespace 8021: 8022: =item eget 8023: 8024: returns hash with keys from array 8025: reference filled in from namesp (encrypts the return communication) 8026: 8027: =item rolesget 8028: 8029: get a role from a user's environment 8030: 8031: =item del 8032: 8033: deletes keys out of array from namespace 8034: 8035: =item keys 8036: 8037: returns namespace keys 8038: 8039: =item dump 8040: 8041: dumps the complete (or key matching regexp) namespace into a hash 8042: 8043: =item store 8044: 8045: stores hash permanently 8046: for this url; hashref needs to be given and should be a \%hashname; the 8047: remaining args aren't required and if they aren't passed or are '' they will 8048: be derived from the ENV 8049: 8050: =item restore 8051: 8052: returns a hash for a given url 8053: 8054: =item querysend 8055: 8056: Tells client about the lonsql process that has been launched in response 8057: to a sent query. 8058: 8059: =item queryreply 8060: 8061: Accept information from lonsql and make appropriate storage in temporary 8062: file space. 8063: 8064: =item idput 8065: 8066: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers 8067: for each student, defined perhaps by the institutional Registrar.) 8068: 8069: =item idget 8070: 8071: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers 8072: for each student, defined perhaps by the institutional Registrar.) 8073: 8074: =item iddel 8075: 8076: Deletes one or more ids in a domain's id database. 8077: 8078: =item tmpput 8079: 8080: Accept and store information in temporary space. 8081: 8082: =item tmpget 8083: 8084: Send along temporarily stored information. 8085: 8086: =item ls 8087: 8088: List part of a user's directory. 8089: 8090: =item pushtable 8091: 8092: Pushes a file in /home/httpd/lonTab directory. Currently limited to: 8093: hosts.tab and domain.tab. The old file is copied to *.tab.backup but 8094: must be restored manually in case of a problem with the new table file. 8095: pushtable requires that the request be encrypted and validated via 8096: ValidateManager. The form of the command is: 8097: enc:pushtable tablename <tablecontents> \n 8098: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a 8099: cleartext newline. 8100: 8101: =item Hanging up (exit or init) 8102: 8103: What to do when a client tells the server that they (the client) 8104: are leaving the network. 8105: 8106: =item unknown command 8107: 8108: If B<lond> is sent an unknown command (not in the list above), 8109: it replys to the client "unknown_cmd". 8110: 8111: 8112: =item UNKNOWN CLIENT 8113: 8114: If the anti-spoofing algorithm cannot verify the client, 8115: the client is rejected (with a "refused" message sent 8116: to the client, and the connection is closed. 8117: 8118: =back 8119: 8120: =head1 PREREQUISITES 8121: 8122: IO::Socket 8123: IO::File 8124: Apache::File 8125: POSIX 8126: Crypt::IDEA 8127: LWP::UserAgent() 8128: GDBM_File 8129: Authen::Krb4 8130: Authen::Krb5 8131: 8132: =head1 COREQUISITES 8133: 8134: none 8135: 8136: =head1 OSNAMES 8137: 8138: linux 8139: 8140: =head1 SCRIPT CATEGORIES 8141: 8142: Server/Process 8143: 8144: =cut 8145: 8146: 8147: =pod 8148: 8149: =head1 LOG MESSAGES 8150: 8151: The messages below can be emitted in the lond log. This log is located 8152: in ~httpd/perl/logs/lond.log Many log messages have HTML encapsulation 8153: to provide coloring if examined from inside a web page. Some do not. 8154: Where color is used, the colors are; Red for sometihhng to get excited 8155: about and to follow up on. Yellow for something to keep an eye on to 8156: be sure it does not get worse, Green,and Blue for informational items. 8157: 8158: In the discussions below, sometimes reference is made to ~httpd 8159: when describing file locations. There isn't really an httpd 8160: user, however there is an httpd directory that gets installed in the 8161: place that user home directories go. On linux, this is usually 8162: (always?) /home/httpd. 8163: 8164: 8165: Some messages are colorless. These are usually (not always) 8166: Green/Blue color level messages. 8167: 8168: =over 2 8169: 8170: =item (Red) LocalConnection rejecting non local: <ip> ne 127.0.0.1 8171: 8172: A local connection negotiation was attempted by 8173: a host whose IP address was not 127.0.0.1. 8174: The socket is closed and the child will exit. 8175: lond has three ways to establish an encyrption 8176: key with a client: 8177: 8178: =over 2 8179: 8180: =item local 8181: 8182: The key is written and read from a file. 8183: This is only valid for connections from localhost. 8184: 8185: =item insecure 8186: 8187: The key is generated by the server and 8188: transmitted to the client. 8189: 8190: =item ssl (secure) 8191: 8192: An ssl connection is negotiated with the client, 8193: the key is generated by the server and sent to the 8194: client across this ssl connection before the 8195: ssl connectionis terminated and clear text 8196: transmission resumes. 8197: 8198: =back 8199: 8200: =item (Red) LocalConnection: caller is insane! init = <init> and type = <type> 8201: 8202: The client is local but has not sent an initialization 8203: string that is the literal "init:local" The connection 8204: is closed and the child exits. 8205: 8206: =item Red CRITICAL Can't get key file <error> 8207: 8208: SSL key negotiation is being attempted but the call to 8209: lonssl::KeyFile failed. This usually means that the 8210: configuration file is not correctly defining or protecting 8211: the directories/files lonCertificateDirectory or 8212: lonnetPrivateKey 8213: <error> is a string that describes the reason that 8214: the key file could not be located. 8215: 8216: =item (Red) CRITICAL Can't get certificates <error> 8217: 8218: SSL key negotiation failed because we were not able to retrives our certificate 8219: or the CA's certificate in the call to lonssl::CertificateFile 8220: <error> is the textual reason this failed. Usual reasons: 8221: 8222: =over 2 8223: 8224: =item Apache config file for loncapa incorrect: 8225: 8226: one of the variables 8227: lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate 8228: undefined or incorrect 8229: 8230: =item Permission error: 8231: 8232: The directory pointed to by lonCertificateDirectory is not readable by lond 8233: 8234: =item Permission error: 8235: 8236: Files in the directory pointed to by lonCertificateDirectory are not readable by lond. 8237: 8238: =item Installation error: 8239: 8240: Either the certificate authority file or the certificate have not 8241: been installed in lonCertificateDirectory. 8242: 8243: =item (Red) CRITICAL SSL Socket promotion failed: <err> 8244: 8245: The promotion of the connection from plaintext to SSL failed 8246: <err> is the reason for the failure. There are two 8247: system calls involved in the promotion (one of which failed), 8248: a dup to produce 8249: a second fd on the raw socket over which the encrypted data 8250: will flow and IO::SOcket::SSL->new_from_fd which creates 8251: the SSL connection on the duped fd. 8252: 8253: =item (Blue) WARNING client did not respond to challenge 8254: 8255: This occurs on an insecure (non SSL) connection negotiation request. 8256: lond generates some number from the time, the PID and sends it to 8257: the client. The client must respond by echoing this information back. 8258: If the client does not do so, that's a violation of the challenge 8259: protocols and the connection will be failed. 8260: 8261: =item (Red) No manager table. Nobody can manage!! 8262: 8263: lond has the concept of privileged hosts that 8264: can perform remote management function such 8265: as update the hosts.tab. The manager hosts 8266: are described in the 8267: ~httpd/lonTabs/managers.tab file. 8268: this message is logged if this file is missing. 8269: 8270: 8271: =item (Green) Registering manager <dnsname> as <cluster_name> with <ipaddress> 8272: 8273: Reports the successful parse and registration 8274: of a specific manager. 8275: 8276: =item Green existing host <clustername:dnsname> 8277: 8278: The manager host is already defined in the hosts.tab 8279: the information in that table, rather than the info in the 8280: manager table will be used to determine the manager's ip. 8281: 8282: =item (Red) Unable to craete <filename> 8283: 8284: lond has been asked to create new versions of an administrative 8285: file (by a manager). When this is done, the new file is created 8286: in a temp file and then renamed into place so that there are always 8287: usable administrative files, even if the update fails. This failure 8288: message means that the temp file could not be created. 8289: The update is abandoned, and the old file is available for use. 8290: 8291: =item (Green) CopyFile from <oldname> to <newname> failed 8292: 8293: In an update of administrative files, the copy of the existing file to a 8294: backup file failed. The installation of the new file may still succeed, 8295: but there will not be a back up file to rever to (this should probably 8296: be yellow). 8297: 8298: =item (Green) Pushfile: backed up <oldname> to <newname> 8299: 8300: See above, the backup of the old administrative file succeeded. 8301: 8302: =item (Red) Pushfile: Unable to install <filename> <reason> 8303: 8304: The new administrative file could not be installed. In this case, 8305: the old administrative file is still in use. 8306: 8307: =item (Green) Installed new < filename>. 8308: 8309: The new administrative file was successfullly installed. 8310: 8311: =item (Red) Reinitializing lond pid=<pid> 8312: 8313: The lonc child process <pid> will be sent a USR2 8314: signal. 8315: 8316: =item (Red) Reinitializing self 8317: 8318: We've been asked to re-read our administrative files,and 8319: are doing so. 8320: 8321: =item (Yellow) error:Invalid process identifier <ident> 8322: 8323: A reinit command was received, but the target part of the 8324: command was not valid. It must be either 8325: 'lond' or 'lonc' but was <ident> 8326: 8327: =item (Green) isValideditCommand checking: Command = <command> Key = <key> newline = <newline> 8328: 8329: Checking to see if lond has been handed a valid edit 8330: command. It is possible the edit command is not valid 8331: in that case there are no log messages to indicate that. 8332: 8333: =item Result of password change for <username> pwchange_success 8334: 8335: The password for <username> was 8336: successfully changed. 8337: 8338: =item Unable to open <user> passwd to change password 8339: 8340: Could not rewrite the 8341: internal password file for a user 8342: 8343: =item Result of password change for <user> : <result> 8344: 8345: A unix password change for <user> was attempted 8346: and the pipe returned <result> 8347: 8348: =item LWP GET: <message> for <fname> (<remoteurl>) 8349: 8350: The lightweight process fetch for a resource failed 8351: with <message> the local filename that should 8352: have existed/been created was <fname> the 8353: corresponding URI: <remoteurl> This is emitted in several 8354: places. 8355: 8356: =item Unable to move <transname> to <destname> 8357: 8358: From fetch_user_file_handler - the user file was replicated but could not 8359: be mv'd to its final location. 8360: 8361: =item Looking for <domain> <username> 8362: 8363: From user_has_session_handler - This should be a Debug call instead 8364: it indicates lond is about to check whether the specified user has a 8365: session active on the specified domain on the local host. 8366: 8367: =item Client <ip> (<name>) hanging up: <input> 8368: 8369: lond has been asked to exit by its client. The <ip> and <name> identify the 8370: client systemand <input> is the full exit command sent to the server. 8371: 8372: =item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>]. 8373: 8374: A lond child terminated. NOte that this termination can also occur when the 8375: child receives the QUIT or DIE signals. <pid> is the process id of the child, 8376: <hostname> the host lond is working for, and <message> the reason the child died 8377: to the best of our ability to get it (I would guess that any numeric value 8378: represents and errno value). This is immediately followed by 8379: 8380: =item Famous last words: Catching exception - <log> 8381: 8382: Where log is some recent information about the state of the child. 8383: 8384: =item Red CRITICAL: TIME OUT <pid> 8385: 8386: Some timeout occured for server <pid>. THis is normally a timeout on an LWP 8387: doing an HTTP::GET. 8388: 8389: =item child <pid> died 8390: 8391: The reaper caught a SIGCHILD for the lond child process <pid> 8392: This should be modified to also display the IP of the dying child 8393: $children{$pid} 8394: 8395: =item Unknown child 0 died 8396: A child died but the wait for it returned a pid of zero which really should not 8397: ever happen. 8398: 8399: =item Child <which> - <pid> looks like we missed it's death 8400: 8401: When a sigchild is received, the reaper process checks all children to see if they are 8402: alive. If children are dying quite quickly, the lack of signal queuing can mean 8403: that a signal hearalds the death of more than one child. If so this message indicates 8404: which other one died. <which> is the ip of a dead child 8405: 8406: =item Free socket: <shutdownretval> 8407: 8408: The HUNTSMAN sub was called due to a SIGINT in a child process. The socket is being shutdown. 8409: for whatever reason, <shutdownretval> is printed but in fact shutdown() is not documented 8410: to return anything. This is followed by: 8411: 8412: =item Red CRITICAL: Shutting down 8413: 8414: Just prior to exit. 8415: 8416: =item Free socket: <shutdownretval> 8417: 8418: The HUPSMAN sub was called due to a SIGHUP. all children get killsed, and lond execs itself. 8419: This is followed by: 8420: 8421: =item (Red) CRITICAL: Restarting 8422: 8423: lond is about to exec itself to restart. 8424: 8425: =item (Blue) Updating connections 8426: 8427: (In response to a USR2). All the children (except the one for localhost) 8428: are about to be killed, the hosts tab reread, and Apache reloaded via apachereload. 8429: 8430: =item (Blue) UpdateHosts killing child <pid> for ip <ip> 8431: 8432: Due to USR2 as above. 8433: 8434: =item (Green) keeping child for ip <ip> (pid = <pid>) 8435: 8436: In response to USR2 as above, the child indicated is not being restarted because 8437: it's assumed that we'll always need a child for the localhost. 8438: 8439: 8440: =item Going to check on the children 8441: 8442: Parent is about to check on the health of the child processes. 8443: Note that this is in response to a USR1 sent to the parent lond. 8444: there may be one or more of the next two messages: 8445: 8446: =item <pid> is dead 8447: 8448: A child that we have in our child hash as alive has evidently died. 8449: 8450: =item Child <pid> did not respond 8451: 8452: In the health check the child <pid> did not update/produce a pid_.txt 8453: file when sent it's USR1 signal. That process is killed with a 9 signal, as it's 8454: assumed to be hung in some un-fixable way. 8455: 8456: =item Finished checking children 8457: 8458: Master processs's USR1 processing is cojmplete. 8459: 8460: =item (Red) CRITICAL: ------- Starting ------ 8461: 8462: (There are more '-'s on either side). Lond has forked itself off to 8463: form a new session and is about to start actual initialization. 8464: 8465: =item (Green) Attempting to start child (<client>) 8466: 8467: Started a new child process for <client>. Client is IO::Socket object 8468: connected to the child. This was as a result of a TCP/IP connection from a client. 8469: 8470: =item Unable to determine who caller was, getpeername returned nothing 8471: 8472: In child process initialization. either getpeername returned undef or 8473: a zero sized object was returned. Processing continues, but in my opinion, 8474: this should be cause for the child to exit. 8475: 8476: =item Unable to determine clientip 8477: 8478: In child process initialization. The peer address from getpeername was not defined. 8479: The client address is stored as "Unavailable" and processing continues. 8480: 8481: =item (Yellow) INFO: Connection <ip> <name> connection type = <type> 8482: 8483: In child initialization. A good connectionw as received from <ip>. 8484: 8485: =over 2 8486: 8487: =item <name> 8488: 8489: is the name of the client from hosts.tab. 8490: 8491: =item <type> 8492: 8493: Is the connection type which is either 8494: 8495: =over 2 8496: 8497: =item manager 8498: 8499: The connection is from a manager node, not in hosts.tab 8500: 8501: =item client 8502: 8503: the connection is from a non-manager in the hosts.tab 8504: 8505: =item both 8506: 8507: The connection is from a manager in the hosts.tab. 8508: 8509: =back 8510: 8511: =back 8512: 8513: =item (Blue) Certificates not installed -- trying insecure auth 8514: 8515: One of the certificate file, key file or 8516: certificate authority file could not be found for a client attempting 8517: SSL connection intiation. COnnection will be attemptied in in-secure mode. 8518: (this would be a system with an up to date lond that has not gotten a 8519: certificate from us). 8520: 8521: =item (Green) Successful local authentication 8522: 8523: A local connection successfully negotiated the encryption key. 8524: In this case the IDEA key is in a file (that is hopefully well protected). 8525: 8526: =item (Green) Successful ssl authentication with <client> 8527: 8528: The client (<client> is the peer's name in hosts.tab), has successfully 8529: negotiated an SSL connection with this child process. 8530: 8531: =item (Green) Successful insecure authentication with <client> 8532: 8533: 8534: The client has successfully negotiated an insecure connection withthe child process. 8535: 8536: =item (Yellow) Attempted insecure connection disallowed 8537: 8538: The client attempted and failed to successfully negotiate a successful insecure 8539: connection. This can happen either because the variable londAllowInsecure is false 8540: or undefined, or becuse the child did not successfully echo back the challenge 8541: string. 8542: 8543: 8544: =back 8545: 8546: =back 8547: 8548: 8549: =cut