loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.533: download - view: text, annotated - select for diffs
Mon Mar 13 18:30:02 2017 UTC (7 years, 1 month ago) by raeburn
Branches: MAIN
CVS tags: HEAD

- Domain configuration for internally authenticated users.
  - (a) Option to switch from crypt to bcrypt automatically when user is authenticated.
  - (b) Option to set bcrypt cost.
  - (c) Option to compare bcrypt cost for user with current domain config
        when user is authenticated.
  Defaults are: (a) No, (b) 10; (c) No

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