loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.538: download - view: text, annotated - select for diffs
Tue Jun 6 13:32:38 2017 UTC (6 years, 10 months ago) by raeburn
Branches: MAIN
CVS tags: HEAD

- Sanity checking changes in rev. 1.529 for ls3, ls2, and ls were too
  restrictive, as lonnet::dirlist() which leverages ls3 etc. is called by
  lonnet::stat_file() to retrieve status an individual file in /res/.

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