loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.178.2.8: download - view: text, annotated - select for diffs
Tue Mar 16 10:52:30 2004 UTC (20 years, 2 months ago) by foxr
Branches: Refactoring

Compiles ok with
- Password functions factored out.
- Hash tying functions factored out.
Not tested so don't trust this version!!!

1: #!/usr/bin/perl 2: # The LearningOnline Network 3: # lond "LON Daemon" Server (port "LOND" 5663) 4: # 5: # $Id: lond,v 1.178.2.8 2004/03/16 10:52:30 foxr 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::Configuration; 35: 36: use IO::Socket; 37: use IO::File; 38: #use Apache::File; 39: use Symbol; 40: use POSIX; 41: use Crypt::IDEA; 42: use LWP::UserAgent(); 43: use GDBM_File; 44: use Authen::Krb4; 45: use Authen::Krb5; 46: use lib '/home/httpd/lib/perl/'; 47: use localauth; 48: use File::Copy; 49: use LONCAPA::ConfigFileEdit; 50: 51: my $DEBUG = 1; # Non zero to enable debug log entries. 52: 53: my $status=''; 54: my $lastlog=''; 55: 56: my $VERSION='$Revision: 1.178.2.8 $'; #' stupid emacs 57: my $remoteVERSION; 58: my $currenthostid; 59: my $currentdomainid; 60: 61: my $client; 62: my $clientip; 63: my $clientname; 64: 65: my $cipher; # Cipher key negotiated with client. 66: my $tmpsnum = 0;; # Id of tmpputs. 67: 68: my $server; 69: my $thisserver; 70: 71: # 72: # Connection type is: 73: # client - All client actions are allowed 74: # manager - only management functions allowed. 75: # both - Both management and client actions are allowed 76: # 77: 78: my $ConnectionType; 79: 80: my %hostid; 81: my %hostdom; 82: my %hostip; 83: 84: my %managers; # Ip -> manager names 85: 86: my %perlvar; # Will have the apache conf defined perl vars. 87: 88: # 89: # The hash below is used for command dispatching, and is therefore keyed on the request keyword. 90: # Each element of the hash contains a reference to an array that contains: 91: # A reference to a sub that executes the request corresponding to the keyword. 92: # A flag that is true if the request must be encoded to be acceptable. 93: # A mask with bits as follows: 94: # CLIENT_OK - Set when the function is allowed by ordinary clients 95: # MANAGER_OK - Set when the function is allowed to manager clients. 96: # 97: my $CLIENT_OK = 1; 98: my $MANAGER_OK = 2; 99: my %Dispatcher; 100: 101: # 102: # The array below are password error strings." 103: # 104: my $lastpwderror = 13; # Largest error number from lcpasswd. 105: my @passwderrors = ("ok", 106: "lcpasswd must be run as user 'www'", 107: "lcpasswd got incorrect number of arguments", 108: "lcpasswd did not get the right nubmer of input text lines", 109: "lcpasswd too many simultaneous pwd changes in progress", 110: "lcpasswd User does not exist.", 111: "lcpasswd Incorrect current passwd", 112: "lcpasswd Unable to su to root.", 113: "lcpasswd Cannot set new passwd.", 114: "lcpasswd Username has invalid characters", 115: "lcpasswd Invalid characters in password", 116: "11", "12", 117: "lcpasswd Password mismatch"); 118: 119: 120: # The array below are lcuseradd error strings.: 121: 122: my $lastadderror = 13; 123: my @adderrors = ("ok", 124: "User ID mismatch, lcuseradd must run as user www", 125: "lcuseradd Incorrect number of command line parameters must be 3", 126: "lcuseradd Incorrect number of stdinput lines, must be 3", 127: "lcuseradd Too many other simultaneous pwd changes in progress", 128: "lcuseradd User does not exist", 129: "lcuseradd Unable to make www member of users's group", 130: "lcuseradd Unable to su to root", 131: "lcuseradd Unable to set password", 132: "lcuseradd Usrname has invalid characters", 133: "lcuseradd Password has an invalid character", 134: "lcuseradd User already exists", 135: "lcuseradd Could not add user.", 136: "lcuseradd Password mismatch"); 137: 138: # 139: # Statistics that are maintained and dislayed in the status line. 140: # 141: my $Transactions; # Number of attempted transactions. 142: my $Failures; # Number of transcations failed. 143: 144: # ResetStatistics: 145: # Resets the statistics counters: 146: # 147: sub ResetStatistics { 148: $Transactions = 0; 149: $Failures = 0; 150: } 151: 152: # 153: # Return true if client is a manager. 154: # 155: sub isManager { 156: return (($ConnectionType eq "manager") || ($ConnectionType eq "both")); 157: } 158: # 159: # Return tru if client can do client functions 160: # 161: sub isClient { 162: return (($ConnectionType eq "client") || ($ConnectionType eq "both")); 163: } 164: # 165: # Ties a resource file to a hash. If necessary, an appropriate history 166: # log file entry is made as well. 167: # This sub factors out common code from the subs that manipulate 168: # the various gdbm files that keep keyword value pairs. 169: # Parameters: 170: # domain - Name of the domain the user is in. 171: # user - Name of the 'current user'. 172: # namespace - Namespace representing the file to tie. 173: # how - What the tie is done to (e.g. GDBM_WRCREAT(). 174: # loghead - Optional first part of log entry if there may be a 175: # history file. 176: # what - Optional tail of log entry if there may be a history 177: # file. 178: # Returns: 179: # hash to which the database is tied. It's up to the caller to untie. 180: # undef if the has could not be tied. 181: # 182: sub TieResourceHash { 183: my $domain = shift; 184: my $user = shift; 185: my $namespace = shift; 186: my $how = shift; 187: 188: $namespace=~s/\//\_/g; # / -> _ 189: $namespace=~s/\W//g; # whitespace eliminated. 190: my $proname = propath($domain, $user); 191: 192: # If this is a namespace for which a history is kept, 193: # make the history log entry: 194: 195: 196: unless ($namespace =~/^nohist\_/ && (scalar @_ > 0)) { 197: my $hfh = IO::File->new(">>$proname/$namespace.hist"); 198: if($hfh) { 199: my $now = time; 200: my $loghead = shift; 201: my $what = shift; 202: print $hfh "$loghead:$now:$what\n"; 203: } 204: } 205: # Tie the database. 206: 207: my %hash; 208: if(tie(%hash, 'GDBM_FILE', "$proname/$namespace.db", 209: $how, 0640)) { 210: return \%hash; 211: } 212: else { 213: return undef; 214: } 215: 216: } 217: 218: # 219: # Get a Request: 220: # Gets a Request message from the client. The transaction 221: # is defined as a 'line' of text. We remove the new line 222: # from the text line. 223: # 224: sub GetRequest { 225: my $input = <$client>; 226: chomp($input); 227: 228: Debug("Request = $input\n"); 229: 230: &status('Processing '.$clientname.':'.$input); 231: 232: return $input; 233: } 234: # 235: # Decipher encoded traffic 236: # Parameters: 237: # input - Encoded data. 238: # Returns: 239: # Decoded data or undef if encryption key was not yet negotiated. 240: # Implicit input: 241: # cipher - This global holds the negotiated encryption key. 242: # 243: sub Decipher { 244: my $input = shift; 245: my $output = ''; 246: 247: 248: if($cipher) { 249: my($enc, $enclength, $encinput) = split(/:/, $input); 250: for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) { 251: $output .= 252: $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16))); 253: } 254: return substr($output, 0, $enclength); 255: } else { 256: return undef; 257: } 258: } 259: 260: # 261: # Register a command processor. This function is invoked to register a sub 262: # to process a request. Once registered, the ProcessRequest sub can automatically 263: # dispatch requests to an appropriate sub, and do the top level validity checking 264: # as well: 265: # - Is the keyword recognized. 266: # - Is the proper client type attempting the request. 267: # - Is the request encrypted if it has to be. 268: # Parameters: 269: # $RequestName - Name of the request being registered. 270: # This is the command request that will match 271: # against the hash keywords to lookup the information 272: # associated with the dispatch information. 273: # $Procedure - Reference to a sub to call to process the request. 274: # All subs get called as follows: 275: # Procedure($cmd, $tail, $replyfd, $key) 276: # $cmd - the actual keyword that invoked us. 277: # $tail - the tail of the request that invoked us. 278: # $replyfd- File descriptor connected to the client 279: # $MustEncode - True if the request must be encoded to be good. 280: # $ClientOk - True if it's ok for a client to request this. 281: # $ManagerOk - True if it's ok for a manager to request this. 282: # Side effects: 283: # - On success, the Dispatcher hash has an entry added for the key $RequestName 284: # - On failure, the program will die as it's a bad internal bug to try to 285: # register a duplicate command handler. 286: # 287: sub RegisterHandler { 288: my $RequestName = shift; 289: my $Procedure = shift; 290: my $MustEncode = shift; 291: my $ClientOk = shift; 292: my $ManagerOk = shift; 293: 294: # Don't allow duplication# 295: 296: if (defined $Dispatcher{$RequestName}) { 297: die "Attempting to define a duplicate request handler for $RequestName\n"; 298: } 299: # Build the client type mask: 300: 301: my $ClientTypeMask = 0; 302: if($ClientOk) { 303: $ClientTypeMask |= $CLIENT_OK; 304: } 305: if($ManagerOk) { 306: $ClientTypeMask |= $MANAGER_OK; 307: } 308: 309: # Enter the hash: 310: 311: my @entry = ($Procedure, $MustEncode, $ClientTypeMask); 312: 313: $Dispatcher{$RequestName} = \@entry; 314: 315: 316: } 317: 318: #--------------------- Request Handlers -------------------------------------------- 319: # 320: # By convention each request handler registers itself prior to the sub declaration: 321: # 322: 323: # Handles ping requests. 324: # Parameters: 325: # $cmd - the actual keyword that invoked us. 326: # $tail - the tail of the request that invoked us. 327: # $replyfd- File descriptor connected to the client 328: # Implicit Inputs: 329: # $currenthostid - Global variable that carries the name of the host we are 330: # known as. 331: # Returns: 332: # 1 - Ok to continue processing. 333: # 0 - Program should exit. 334: # Side effects: 335: # Reply information is sent to the client. 336: 337: sub PingHandler { 338: my $cmd = shift; 339: my $tail = shift; 340: my $client = shift; 341: 342: Reply( $client,"$currenthostid\n","$cmd:$tail"); 343: 344: return 1; 345: } 346: RegisterHandler("ping", \&PingHandler, 0, 1, 1); # Ping unencoded, client or manager. 347: # 348: # Handles pong reequests: 349: # Parameters: 350: # $cmd - the actual keyword that invoked us. 351: # $tail - the tail of the request that invoked us. 352: # $replyfd- File descriptor connected to the client 353: # Implicit Inputs: 354: # $currenthostid - Global variable that carries the name of the host we are 355: # connected to. 356: # Returns: 357: # 1 - Ok to continue processing. 358: # 0 - Program should exit. 359: # Side effects: 360: # Reply information is sent to the client. 361: 362: sub PongHandler { 363: my $cmd = shift; 364: my $tail = shift; 365: my $replyfd = shift; 366: 367: my $reply=&reply("ping",$clientname); 368: Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 369: return 1; 370: } 371: RegisterHandler("pong", \&PongHandler, 0, 1, 1); # Pong unencoded, client or manager 372: 373: # 374: # EstablishKeyHandler: 375: # Called to establish an encrypted session key with the remote client. 376: # 377: # Parameters: 378: # $cmd - the actual keyword that invoked us. 379: # $tail - the tail of the request that invoked us. 380: # $replyfd- File descriptor connected to the client 381: # Implicit Inputs: 382: # $currenthostid - Global variable that carries the name of the host 383: # known as. 384: # $clientname - Global variable that carries the name of the hsot we're connected to. 385: # Returns: 386: # 1 - Ok to continue processing. 387: # 0 - Program should exit. 388: # Implicit Outputs: 389: # Reply information is sent to the client. 390: # $cipher is set with a reference to a new IDEA encryption object. 391: # 392: sub EstablishKeyHandler { 393: my $cmd = shift; 394: my $tail = shift; 395: my $replyfd = shift; 396: 397: my $buildkey=time.$$.int(rand 100000); 398: $buildkey=~tr/1-6/A-F/; 399: $buildkey=int(rand 100000).$buildkey.int(rand 100000); 400: my $key=$currenthostid.$clientname; 401: $key=~tr/a-z/A-Z/; 402: $key=~tr/G-P/0-9/; 403: $key=~tr/Q-Z/0-9/; 404: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey; 405: $key=substr($key,0,32); 406: my $cipherkey=pack("H32",$key); 407: $cipher=new IDEA $cipherkey; 408: Reply($replyfd, "$buildkey\n", "$cmd:$tail"); 409: 410: return 1; 411: 412: } 413: RegisterHandler("ekey", \&EstablishKeyHandler, 0, 1,1); 414: 415: # LoadHandler: 416: # Handler for the load command. Returns the current system load average 417: # to the requestor. 418: # 419: # Parameters: 420: # $cmd - the actual keyword that invoked us. 421: # $tail - the tail of the request that invoked us. 422: # $replyfd- File descriptor connected to the client 423: # Implicit Inputs: 424: # $currenthostid - Global variable that carries the name of the host 425: # known as. 426: # $clientname - Global variable that carries the name of the hsot we're connected to. 427: # Returns: 428: # 1 - Ok to continue processing. 429: # 0 - Program should exit. 430: # Side effects: 431: # Reply information is sent to the client. 432: sub LoadHandler { 433: my $cmd = shift; 434: my $tail = shift; 435: my $replyfd = shift; 436: 437: # Get the load average from /proc/loadavg and calculate it as a percentage of 438: # the allowed load limit as set by the perl global variable lonLoadLim 439: 440: my $loadavg; 441: my $loadfile=IO::File->new('/proc/loadavg'); 442: 443: $loadavg=<$loadfile>; 444: $loadavg =~ s/\s.*//g; # Extract the first field only. 445: 446: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; 447: 448: Reply( $replyfd, "$loadpercent\n", "$cmd:$tail"); 449: 450: return 1; 451: } 452: RegisterHandler("load", \&LoadHandler, 0, 1, 0); 453: 454: 455: # 456: # Process the userload request. This sub returns to the client the current 457: # user load average. It can be invoked either by clients or managers. 458: # 459: # Parameters: 460: # $cmd - the actual keyword that invoked us. 461: # $tail - the tail of the request that invoked us. 462: # $replyfd- File descriptor connected to the client 463: # Implicit Inputs: 464: # $currenthostid - Global variable that carries the name of the host 465: # known as. 466: # $clientname - Global variable that carries the name of the hsot we're connected to. 467: # Returns: 468: # 1 - Ok to continue processing. 469: # 0 - Program should exit 470: # Implicit inputs: 471: # whatever the userload() function requires. 472: # Implicit outputs: 473: # the reply is written to the client. 474: # 475: sub UserLoadHandler { 476: my $cmd = shift; 477: my $tail = shift; 478: my $replyfd = shift; 479: 480: my $userloadpercent=&userload(); 481: Reply($replyfd, "$userloadpercent\n", "$cmd:$tail"); 482: 483: return 1; 484: } 485: RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0); 486: 487: # Process a request for the authorization type of a user: 488: # (userauth). 489: # 490: # Parameters: 491: # $cmd - the actual keyword that invoked us. 492: # $tail - the tail of the request that invoked us. 493: # $replyfd- File descriptor connected to the client 494: # Returns: 495: # 1 - Ok to continue processing. 496: # 0 - Program should exit 497: # Implicit outputs: 498: # The user authorization type is written to the client. 499: # 500: sub UserAuthorizationType { 501: my $cmd = shift; 502: my $tail = shift; 503: my $replyfd = shift; 504: 505: my $userinput = "$cmd:$tail"; 506: 507: # Pull the domain and username out of the command tail. 508: # and call GetAuthType to determine the authentication type. 509: 510: my ($udom,$uname)=split(/:/,$tail); 511: my $result = GetAuthType($udom, $uname); 512: if($result eq "nouser") { 513: Failure( $replyfd, "unknown_user\n", $userinput); 514: } else { 515: # 516: # We only want to pass the second field from GetAuthType 517: # for ^krb.. otherwise we'll be handing out the encrypted 518: # password for internals e.g. 519: # 520: my ($type,$otherinfo) = split(/:/,$result); 521: if($type =~ /^krb/) { 522: $type = $result; 523: } 524: Reply( $replyfd, "$type\n", $userinput); 525: } 526: 527: return 1; 528: } 529: RegisterHandler("currentauth", \&UserAuthorizationType, 1, 1, 0); 530: # 531: # Process a request by a manager to push a hosts or domain table 532: # to us. We pick apart the command and pass it on to the subs 533: # that already exist to do this. 534: # 535: # Parameters: 536: # $cmd - the actual keyword that invoked us. 537: # $tail - the tail of the request that invoked us. 538: # $client - File descriptor connected to the client 539: # Returns: 540: # 1 - Ok to continue processing. 541: # 0 - Program should exit 542: # Implicit Output: 543: # a reply is written to the client. 544: 545: sub PushFileHandler { 546: my $cmd = shift; 547: my $tail = shift; 548: my $client = shift; 549: 550: my $userinput = "$cmd:$tail"; 551: 552: # At this time we only know that the IP of our partner is a valid manager 553: # the code below is a hook to do further authentication (e.g. to resolve 554: # spoofing). 555: 556: my $cert = GetCertificate($userinput); 557: if(ValidManager($cert)) { 558: 559: # Now presumably we have the bona fides of both the peer host and the 560: # process making the request. 561: 562: my $reply = PushFile($userinput); 563: Reply($client, "$reply\n", $userinput); 564: 565: } else { 566: Failure( $client, "refused\n", $userinput); 567: } 568: } 569: RegisterHandler("pushfile", \&PushFileHandler, 1, 0, 1); 570: 571: 572: 573: # Process a reinit request. Reinit requests that either 574: # lonc or lond be reinitialized so that an updated 575: # host.tab or domain.tab can be processed. 576: # 577: # Parameters: 578: # $cmd - the actual keyword that invoked us. 579: # $tail - the tail of the request that invoked us. 580: # $client - File descriptor connected to the client 581: # Returns: 582: # 1 - Ok to continue processing. 583: # 0 - Program should exit 584: # Implicit output: 585: # a reply is sent to the client. 586: # 587: sub ReinitProcessHandler { 588: my $cmd = shift; 589: my $tail = shift; 590: my $client = shift; 591: 592: my $userinput = "$cmd:$tail"; 593: 594: my $cert = GetCertificate($userinput); 595: if(ValidManager($cert)) { 596: chomp($userinput); 597: my $reply = ReinitProcess($userinput); 598: Reply( $client, "$reply\n", $userinput); 599: } else { 600: Failure( $client, "refused\n", $userinput); 601: } 602: return 1; 603: } 604: 605: RegisterHandler("reinit", \&ReinitProcessHandler, 1, 0, 1); 606: 607: # Process the editing script for a table edit operation. 608: # the editing operation must be encrypted and requested by 609: # a manager host. 610: # 611: # Parameters: 612: # $cmd - the actual keyword that invoked us. 613: # $tail - the tail of the request that invoked us. 614: # $client - File descriptor connected to the client 615: # Returns: 616: # 1 - Ok to continue processing. 617: # 0 - Program should exit 618: # Implicit output: 619: # a reply is sent to the client. 620: # 621: sub EditTableHandler { 622: my $command = shift; 623: my $tail = shift; 624: my $client = shift; 625: 626: my $userinput = "$command:$tail"; 627: 628: my $cert = GetCertificate($userinput); 629: if(ValidManager($cert)) { 630: my($filetype, $script) = split(/:/, $tail); 631: if (($filetype eq "hosts") || 632: ($filetype eq "domain")) { 633: if($script ne "") { 634: Reply($client, # BUGBUG - EditFile 635: EditFile($userinput), # could fail. 636: $userinput); 637: } else { 638: Failure($client,"refused\n",$userinput); 639: } 640: } else { 641: Failure($client,"refused\n",$userinput); 642: } 643: } else { 644: Failure($client,"refused\n",$userinput); 645: } 646: return 1; 647: } 648: RegisterHandler("edit", \&EditTableHandler, 1, 0, 1); 649: 650: 651: # 652: # Authenticate a user against the LonCAPA authentication 653: # database. Note that there are several authentication 654: # possibilities: 655: # - unix - The user can be authenticated against the unix 656: # password file. 657: # - internal - The user can be authenticated against a purely 658: # internal per user password file. 659: # - kerberos - The user can be authenticated against either a kerb4 or kerb5 660: # ticket granting authority. 661: # - user - The person tailoring LonCAPA can supply a user authentication 662: # mechanism that is per system. 663: # 664: # Parameters: 665: # $cmd - The command that got us here. 666: # $tail - Tail of the command (remaining parameters). 667: # $client - File descriptor connected to client. 668: # Returns 669: # 0 - Requested to exit, caller should shut down. 670: # 1 - Continue processing. 671: # Implicit inputs: 672: # The authentication systems describe above have their own forms of implicit 673: # input into the authentication process that are described above. 674: # 675: sub AuthenticateHandler { 676: my $cmd = shift; 677: my $tail = shift; 678: my $client = shift; 679: 680: # Regenerate the full input line 681: 682: my $userinput = $cmd.":".$tail; 683: 684: # udom - User's domain. 685: # uname - Username. 686: # upass - User's password. 687: 688: my ($udom,$uname,$upass)=split(/:/,$tail); 689: Debug(" Authenticate domain = $udom, user = $uname, password = $upass"); 690: chomp($upass); 691: $upass=unescape($upass); 692: 693: # Fetch the user authentication information: 694: 695: my $realpasswd = GetAuthType($udom, $uname); 696: if($realpasswd ne "nouser") { # nouser means no passwd file. 697: my ($howpwd,$contentpwd)=split(/:/,$realpasswd); 698: my $pwdcorrect=0; 699: # 700: # Authenticate against password stored in the internal file. 701: # 702: Debug("Authenticating via $howpwd"); 703: if ($howpwd eq 'internal') { 704: &Debug("Internal auth"); 705: $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd); 706: # 707: # Authenticate against the unix password file. 708: # 709: } elsif ($howpwd eq 'unix') { 710: &Debug("Unix auth"); 711: if((getpwnam($uname))[1] eq "") { #no such user! 712: $pwdcorrect = 0; 713: } else { 714: $contentpwd=(getpwnam($uname))[1]; 715: my $pwauth_path="/usr/local/sbin/pwauth"; 716: unless ($contentpwd eq 'x') { # Not in shadow file. 717: $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd); 718: } elsif (-e $pwauth_path) { # In shadow file so 719: open PWAUTH, "|$pwauth_path" or # use external program 720: die "Cannot invoke authentication"; 721: print PWAUTH "$uname\n$upass\n"; 722: close PWAUTH; 723: $pwdcorrect=!$?; 724: } 725: } 726: # 727: # Authenticate against a Kerberos 4 server: 728: # 729: } elsif ($howpwd eq 'krb4') { 730: my $null=pack("C",0); 731: unless ($upass=~/$null/) { 732: my $krb4_error = &Authen::Krb4::get_pw_in_tkt($uname, 733: "", 734: $contentpwd, 735: 'krbtgt', 736: $contentpwd, 737: 1, 738: $upass); 739: if (!$krb4_error) { 740: $pwdcorrect = 1; 741: } else { 742: $pwdcorrect=0; 743: # log error if it is not a bad password 744: if ($krb4_error != 62) { 745: &logthis('krb4:'.$uname.','.$contentpwd.','. 746: &Authen::Krb4::get_err_txt($Authen::Krb4::error)); 747: } 748: } 749: } 750: # 751: # Authenticate against a Kerberos 5 server: 752: # 753: } elsif ($howpwd eq 'krb5') { 754: my $null=pack("C",0); 755: unless ($upass=~/$null/) { 756: my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); 757: my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; 758: my $krbserver=&Authen::Krb5::parse_name($krbservice); 759: my $credentials=&Authen::Krb5::cc_default(); 760: $credentials->initialize($krbclient); 761: my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient, 762: $krbserver, 763: $upass, 764: $credentials); 765: $pwdcorrect = ($krbreturn == 1); 766: } else { 767: $pwdcorrect=0; 768: } 769: # 770: # Finally, the user may have written in an authentication module. 771: # in that case, if requested, authenticate against it. 772: # 773: } elsif ($howpwd eq 'localauth') { 774: $pwdcorrect=&localauth::localauth($uname,$upass,$contentpwd); 775: } 776: # 777: # Successfully authorized. 778: # 779: if ($pwdcorrect) { 780: Reply( $client, "authorized\n", $userinput); 781: # 782: # Bad credentials: Failed to authorize 783: # 784: } else { 785: Failure( $client, "non_authorized\n", $userinput); 786: } 787: # Used to be unknown_user but that allows crackers to 788: # distinguish between bad username and bad password so... 789: # 790: } else { 791: Failure( $client, "non_authorized\n", $userinput); 792: } 793: return 1; 794: } 795: RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0); 796: 797: # 798: # Change a user's password. Note that this function is complicated by 799: # the fact that a user may be authenticated in more than one way: 800: # At present, we are not able to change the password for all types of 801: # authentication methods. Only for: 802: # unix - unix password or shadow passoword style authentication. 803: # local - Locally written authentication mechanism. 804: # For now, kerb4 and kerb5 password changes are not supported and result 805: # in an error. 806: # FUTURE WORK: 807: # Support kerberos passwd changes? 808: # Parameters: 809: # $cmd - The command that got us here. 810: # $tail - Tail of the command (remaining parameters). 811: # $client - File descriptor connected to client. 812: # Returns 813: # 0 - Requested to exit, caller should shut down. 814: # 1 - Continue processing. 815: # Implicit inputs: 816: # The authentication systems describe above have their own forms of implicit 817: # input into the authentication process that are described above. 818: sub ChangePasswordHandler { 819: my $cmd = shift; 820: my $tail = shift; 821: my $client = shift; 822: 823: my $userinput = $cmd.":".$tail; # Reconstruct client's string. 824: 825: # 826: # udom - user's domain. 827: # uname - Username. 828: # upass - Current password. 829: # npass - New password. 830: 831: my ($udom,$uname,$upass,$npass)=split(/:/,$tail); 832: chomp($npass); 833: $upass=&unescape($upass); 834: $npass=&unescape($npass); 835: &Debug("Trying to change password for $uname"); 836: my $realpasswd = GetAuthType($udom, $uname); 837: if ($realpasswd ne "nouser") { 838: my ($howpwd,$contentpwd)=split(/:/,$realpasswd); 839: if ($howpwd eq 'internal') { 840: &Debug("internal auth"); 841: if (crypt($upass,$contentpwd) eq $contentpwd) { 842: my $salt=time; 843: $salt=substr($salt,6,2); 844: my $ncpass=crypt($npass,$salt); 845: if(RewritePwFile($udom, $uname, "internal:$ncpass")) { 846: &logthis("Result of password change for " 847: ."$uname: pwchange_success"); 848: Reply($client, "ok\n", $userinput); 849: } else { 850: &logthis("Unable to open $uname passwd " 851: ."to change password"); 852: Failure( $client, "non_authorized\n",$userinput); 853: } 854: } else { 855: Failure($client, "non_authorized\n", $userinput); 856: } 857: } elsif ($howpwd eq 'unix') { 858: # Unix means we have to access /etc/password 859: # one way or another. 860: # First: Make sure the current password is 861: # correct 862: &Debug("auth is unix"); 863: $contentpwd=(getpwnam($uname))[1]; 864: my $pwdcorrect = "0"; 865: my $pwauth_path="/usr/local/sbin/pwauth"; 866: unless ($contentpwd eq 'x') { 867: $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd); 868: } elsif (-e $pwauth_path) { 869: open PWAUTH, "|$pwauth_path" or 870: die "Cannot invoke authentication"; 871: print PWAUTH "$uname\n$upass\n"; 872: close PWAUTH; 873: &Debug("exited pwauth with $? ($uname,$upass) "); 874: $pwdcorrect=($? == 0); 875: } 876: if ($pwdcorrect) { 877: my $execdir=$perlvar{'lonDaemons'}; 878: &Debug("Opening lcpasswd pipeline"); 879: my $pf = IO::File->new("|$execdir/lcpasswd > " 880: ."$perlvar{'lonDaemons'}" 881: ."/logs/lcpasswd.log"); 882: print $pf "$uname\n$npass\n$npass\n"; 883: close $pf; 884: my $err = $?; 885: my $result = ($err>0 ? 'pwchange_failure' : 'ok'); 886: &logthis("Result of password change for $uname: ". 887: &lcpasswdstrerror($?)); 888: Reply($client, "$result\n", $userinput); 889: } else { 890: Reply($client, "non_authorized\n", $userinput); 891: } 892: } else { 893: # this just means that the current password mode is not 894: # one we know how to change (e.g the kerberos auth modes or 895: # locally written auth handler). 896: # 897: Reply( $client, "auth_mode_error\n", $userinput); 898: } 899: } else { 900: # used to be unknonw user but that gives out too much info.. 901: # so make it the same as if the initial passwd was bad. 902: # 903: Reply( $client, "non_authorized\n", $userinput); 904: } 905: return 1; 906: } 907: RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0); 908: 909: # 910: # Create a new user. User in this case means a lon-capa user. 911: # The user must either already exist in some authentication realm 912: # like kerberos or the /etc/passwd. If not, a user completely local to 913: # this loncapa system is created. 914: # 915: # Parameters: 916: # $cmd - The command that got us here. 917: # $tail - Tail of the command (remaining parameters). 918: # $client - File descriptor connected to client. 919: # Returns 920: # 0 - Requested to exit, caller should shut down. 921: # 1 - Continue processing. 922: # Implicit inputs: 923: # The authentication systems describe above have their own forms of implicit 924: # input into the authentication process that are described above. 925: sub AddUserHandler { 926: my $cmd = shift; 927: my $tail = shift; 928: my $client = shift; 929: 930: my ($udom,$uname,$umode,$npass)=split(/:/,$tail); 931: my $userinput = $cmd.":".$tail; # Reconstruct the full request line. 932: 933: &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname); 934: 935: 936: if($udom eq $currentdomainid) { # Reject new users for other domains... 937: 938: my $oldumask=umask(0077); 939: chomp($npass); 940: $npass=&unescape($npass); 941: my $passfilename = PasswordPath($udom, $uname); 942: &Debug("Password file created will be:".$passfilename); 943: if (-e $passfilename) { 944: Failure( $client, "already_exists\n", $userinput); 945: } else { 946: my @fpparts=split(/\//,$passfilename); 947: my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; 948: my $fperror=''; 949: for (my $i=3;$i<= ($#fpparts-1);$i++) { 950: $fpnow.='/'.$fpparts[$i]; 951: unless (-e $fpnow) { 952: unless (mkdir($fpnow,0777)) { 953: $fperror="error: ".($!+0)." mkdir failed while attempting " 954: ."makeuser"; 955: } 956: } 957: } 958: unless ($fperror) { 959: my $result=&make_passwd_file($uname, $umode,$npass, $passfilename); 960: Reply($client, $result, $userinput); #BUGBUG - could be fail 961: } else { 962: Failure($client, "$fperror\n", $userinput); 963: } 964: } 965: umask($oldumask); 966: } else { 967: Failure($client, "not_right_domain\n", 968: $userinput); # Even if we are multihomed. 969: 970: } 971: return 1; 972: 973: } 974: RegisterHandler("makeuser", \&AddUserHandler, 1, 1, 0); 975: 976: # 977: # Change the authentication method of a user. Note that this may 978: # also implicitly change the user's password if, for example, the user is 979: # joining an existing authentication realm. Known authentication realms at 980: # this time are: 981: # internal - Purely internal password file (only loncapa knows this user) 982: # local - Institutionally written authentication module. 983: # unix - Unix user (/etc/passwd with or without /etc/shadow). 984: # kerb4 - kerberos version 4 985: # kerb5 - kerberos version 5 986: # 987: # Parameters: 988: # $cmd - The command that got us here. 989: # $tail - Tail of the command (remaining parameters). 990: # $client - File descriptor connected to client. 991: # Returns 992: # 0 - Requested to exit, caller should shut down. 993: # 1 - Continue processing. 994: # Implicit inputs: 995: # The authentication systems describe above have their own forms of implicit 996: # input into the authentication process that are described above. 997: # 998: sub ChangeAuthenticationHandler { 999: my $cmd = shift; 1000: my $tail = shift; 1001: my $client = shift; 1002: 1003: my $userinput = "$cmd:$tail"; # Reconstruct user input. 1004: 1005: my ($udom,$uname,$umode,$npass)=split(/:/,$tail); 1006: &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode); 1007: if ($udom ne $currentdomainid) { 1008: Failure( $client, "not_right_domain\n", $client); 1009: } else { 1010: 1011: chomp($npass); 1012: 1013: $npass=&unescape($npass); 1014: my $passfilename = PasswordPath($udom, $uname); 1015: if ($passfilename) { # Not allowed to create a new user!! 1016: my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); 1017: Reply($client, $result, $userinput); 1018: } else { 1019: Failure($client, "non_authorized", $userinput); # Fail the user now. 1020: } 1021: } 1022: return 1; 1023: } 1024: RegisterHandler("changeuserauth", \&ChangeAuthenticationHandler, 1,1, 0); 1025: 1026: # 1027: # Determines if this is the home server for a user. The home server 1028: # for a user will have his/her lon-capa passwd file. Therefore all we need 1029: # to do is determine if this file exists. 1030: # 1031: # Parameters: 1032: # $cmd - The command that got us here. 1033: # $tail - Tail of the command (remaining parameters). 1034: # $client - File descriptor connected to client. 1035: # Returns 1036: # 0 - Requested to exit, caller should shut down. 1037: # 1 - Continue processing. 1038: # Implicit inputs: 1039: # The authentication systems describe above have their own forms of implicit 1040: # input into the authentication process that are described above. 1041: # 1042: sub IsHomeHandler { 1043: my $cmd = shift; 1044: my $tail = shift; 1045: my $client = shift; 1046: 1047: my $userinput = "$cmd:$tail"; 1048: 1049: my ($udom,$uname)=split(/:/,$tail); 1050: chomp($uname); 1051: my $passfile = PasswordPath($udom, $uname); 1052: if($passfile) { 1053: Reply( $client, "found\n", $userinput); 1054: } else { 1055: Failure($client, "not_found\n", $userinput); 1056: } 1057: return 1; 1058: } 1059: RegisterHandler("home", \&IsHomeHandler, 0,1,0); 1060: # 1061: # Process an update request for a resource?? I think what's going on here is 1062: # that a resource has been modified that we hold a subscription to. 1063: # If the resource is not local, then we must update, or at least invalidate our 1064: # cached copy of the resource. 1065: # FUTURE WORK: 1066: # I need to look at this logic carefully. My druthers would be to follow 1067: # typical caching logic, and simple invalidate the cache, drop any subscription 1068: # an let the next fetch start the ball rolling again... however that may 1069: # actually be more difficult than it looks given the complex web of 1070: # proxy servers. 1071: # Parameters: 1072: # $cmd - The command that got us here. 1073: # $tail - Tail of the command (remaining parameters). 1074: # $client - File descriptor connected to client. 1075: # Returns 1076: # 0 - Requested to exit, caller should shut down. 1077: # 1 - Continue processing. 1078: # Implicit inputs: 1079: # The authentication systems describe above have their own forms of implicit 1080: # input into the authentication process that are described above. 1081: # 1082: sub UpdateResourceHandler { 1083: my $cmd = shift; 1084: my $tail = shift; 1085: my $client = shift; 1086: 1087: my $userinput = "$cmd:$tail"; 1088: 1089: my $fname=$tail; 1090: my $ownership=ishome($fname); 1091: if ($ownership eq 'not_owner') { 1092: if (-e $fname) { 1093: my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, 1094: $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname); 1095: my $now=time; 1096: my $since=$now-$atime; 1097: if ($since>$perlvar{'lonExpire'}) { 1098: my $reply=&reply("unsub:$fname","$clientname"); 1099: unlink("$fname"); 1100: } else { 1101: my $transname="$fname.in.transfer"; 1102: my $remoteurl=&reply("sub:$fname","$clientname"); 1103: my $response; 1104: alarm(120); 1105: { 1106: my $ua=new LWP::UserAgent; 1107: my $request=new HTTP::Request('GET',"$remoteurl"); 1108: $response=$ua->request($request,$transname); 1109: } 1110: alarm(0); 1111: if ($response->is_error()) { 1112: unlink($transname); 1113: my $message=$response->status_line; 1114: &logthis("LWP GET: $message for $fname ($remoteurl)"); 1115: } else { 1116: if ($remoteurl!~/\.meta$/) { 1117: alarm(120); 1118: { 1119: my $ua=new LWP::UserAgent; 1120: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); 1121: my $mresponse=$ua->request($mrequest,$fname.'.meta'); 1122: if ($mresponse->is_error()) { 1123: unlink($fname.'.meta'); 1124: } 1125: } 1126: alarm(0); 1127: } 1128: rename($transname,$fname); 1129: } 1130: } 1131: Reply( $client, "ok\n", $userinput); 1132: } else { 1133: Failure($client, "not_found\n", $userinput); 1134: } 1135: } else { 1136: Failure($client, "rejected\n", $userinput); 1137: } 1138: return 1; 1139: } 1140: RegisterHandler("update", \&UpdateResourceHandler, 0 ,1, 0); 1141: 1142: # 1143: # Fetch a user file from a remote server: 1144: # Parameters: 1145: # $cmd - The command that got us here. 1146: # $tail - Tail of the command (remaining parameters). 1147: # $client - File descriptor connected to client. 1148: # Returns 1149: # 0 - Requested to exit, caller should shut down. 1150: # 1 - Continue processing. 1151: # 1152: sub FetchUserFileHandler { 1153: my $cmd = shift; 1154: my $tail = shift; 1155: my $client = shift; 1156: 1157: my $userinput = "$cmd:$tail"; 1158: my $fname = $tail; 1159: my ($udom,$uname,$ufile)=split(/\//,$fname); 1160: my $udir=propath($udom,$uname).'/userfiles'; 1161: unless (-e $udir) { 1162: mkdir($udir,0770); 1163: } 1164: if (-e $udir) { 1165: $ufile=~s/^[\.\~]+//; 1166: $ufile=~s/\///g; 1167: my $destname=$udir.'/'.$ufile; 1168: my $transname=$udir.'/'.$ufile.'.in.transit'; 1169: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; 1170: my $response; 1171: alarm(120); 1172: { 1173: my $ua=new LWP::UserAgent; 1174: my $request=new HTTP::Request('GET',"$remoteurl"); 1175: $response=$ua->request($request,$transname); 1176: } 1177: alarm(0); 1178: if ($response->is_error()) { 1179: unlink($transname); 1180: my $message=$response->status_line; 1181: &logthis("LWP GET: $message for $fname ($remoteurl)"); 1182: Failure($client, "failed\n", $userinput); 1183: } else { 1184: if (!rename($transname,$destname)) { 1185: &logthis("Unable to move $transname to $destname"); 1186: unlink($transname); 1187: Failure($client, "failed\n", $userinput); 1188: } else { 1189: Reply($client, "ok\n", $userinput); 1190: } 1191: } 1192: } else { 1193: Failure($client, "not_home\n", $userinput); 1194: } 1195: return 1; 1196: } 1197: RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0); 1198: # 1199: # Authenticate access to a user file. Question? The token for athentication 1200: # is allowed to be sent as cleartext is this really what we want? This token 1201: # represents the user's session id. Once it is forged does this allow too much 1202: # access?? 1203: # 1204: # Parameters: 1205: # $cmd - The command that got us here. 1206: # $tail - Tail of the command (remaining parameters). 1207: # $client - File descriptor connected to client. 1208: # Returns 1209: # 0 - Requested to exit, caller should shut down. 1210: # 1 - Continue processing. 1211: sub AuthenticateUserFileAccess { 1212: my $cmd = shift; 1213: my $tail = shift; 1214: my $client = shift; 1215: my $userinput = "$cmd:$tail"; 1216: 1217: my ($fname,$session)=split(/:/,$tail); 1218: chomp($session); 1219: my $reply='non_auth'; 1220: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.$session.'.id')) { 1221: while (my $line=<ENVIN>) { 1222: if ($line=~/userfile\.$fname\=/) { 1223: $reply='ok'; 1224: } 1225: } 1226: close(ENVIN); 1227: Reply($client, $reply."\n", $userinput); 1228: } else { 1229: Failure($client, "invalid_token\n", $userinput); 1230: } 1231: return 1; 1232: 1233: } 1234: RegisterHandler("tokenauthuserfile", \&AuthenticateUserFileAccess, 0, 1, 0); 1235: # 1236: # Unsubscribe from a resource. 1237: # 1238: # Parameters: 1239: # $cmd - The command that got us here. 1240: # $tail - Tail of the command (remaining parameters). 1241: # $client - File descriptor connected to client. 1242: # Returns 1243: # 0 - Requested to exit, caller should shut down. 1244: # 1 - Continue processing. 1245: # 1246: sub UnsubscribeHandler { 1247: my $cmd = shift; 1248: my $tail = shift; 1249: my $client = shift; 1250: my $userinput= "$cmd:$tail"; 1251: 1252: my $fname = $tail; 1253: if (-e $fname) { 1254: Reply($client, &unsub($client,$fname,$clientip), $userinput); 1255: } else { 1256: Failure($client, "not_found\n", $userinput); 1257: } 1258: return 1; 1259: } 1260: RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0); 1261: 1262: # Subscribe to a resource. 1263: # 1264: # Parameters: 1265: # $cmd - The command that got us here. 1266: # $tail - Tail of the command (remaining parameters). 1267: # $client - File descriptor connected to client. 1268: # Returns 1269: # 0 - Requested to exit, caller should shut down. 1270: # 1 - Continue processing. 1271: # 1272: sub SubscribeHandler { 1273: my $cmd = shift; 1274: my $tail = shift; 1275: my $client = shift; 1276: my $userinput = "$cmd:$tail"; 1277: 1278: Reply( $client, &subscribe($userinput,$clientip), $userinput); 1279: 1280: return 1; 1281: } 1282: RegisterHandler("sub", \&SubscribeHandler, 0, 1, 0); 1283: 1284: # 1285: # Determine the version of a resource (?) Or is it return 1286: # the top version of the resource? Not yet clear from the 1287: # code in currentversion. 1288: # 1289: # Parameters: 1290: # $cmd - The command that got us here. 1291: # $tail - Tail of the command (remaining parameters). 1292: # $client - File descriptor connected to client. 1293: # Returns 1294: # 0 - Requested to exit, caller should shut down. 1295: # 1 - Continue processing. 1296: # 1297: sub CurrentVersionHandler { 1298: my $cmd = shift; 1299: my $tail = shift; 1300: my $client = shift; 1301: my $userinput= "$cmd:$tail"; 1302: 1303: my $fname = $tail; 1304: Reply( $client, &currentversion($fname)."\n", $userinput); 1305: return 1; 1306: 1307: } 1308: RegisterHandler("currentversion", \&CurrentVersionHandler, 0, 1, 0); 1309: 1310: 1311: # Make an entry in a user's activity log. 1312: # 1313: # Parameters: 1314: # $cmd - The command that got us here. 1315: # $tail - Tail of the command (remaining parameters). 1316: # $client - File descriptor connected to client. 1317: # Returns 1318: # 0 - Requested to exit, caller should shut down. 1319: # 1 - Continue processing. 1320: # 1321: sub ActivityLogEntryHandler { 1322: my $cmd = shift; 1323: my $tail = shift; 1324: my $client = shift; 1325: my $userinput= "$cmd:$tail"; 1326: 1327: my ($udom,$uname,$what)=split(/:/,$tail); 1328: chomp($what); 1329: my $proname=propath($udom,$uname); 1330: my $now=time; 1331: my $hfh; 1332: if ($hfh=IO::File->new(">>$proname/activity.log")) { 1333: print $hfh "$now:$clientname:$what\n"; 1334: Reply( $client, "ok\n", $userinput); 1335: } else { 1336: Failure($client, "error: ".($!+0)." IO::File->new Failed " 1337: ."while attempting log\n", 1338: $userinput); 1339: } 1340: 1341: return 1; 1342: } 1343: RegisterHandler("log", \&ActivityLogEntryHandler, 0, 1, 0); 1344: # 1345: # Put a namespace entry in a user profile hash. 1346: # My druthers would be for this to be an encrypted interaction too. 1347: # anything that might be an inadvertent covert channel about either 1348: # user authentication or user personal information.... 1349: # 1350: # Parameters: 1351: # $cmd - The command that got us here. 1352: # $tail - Tail of the command (remaining parameters). 1353: # $client - File descriptor connected to client. 1354: # Returns 1355: # 0 - Requested to exit, caller should shut down. 1356: # 1 - Continue processing. 1357: # 1358: sub PutUserProfileEntry { 1359: my $cmd = shift; 1360: my $tail = shift; 1361: my $client = shift; 1362: my $userinput = "$cmd:$tail"; 1363: 1364: my ($udom,$uname,$namespace,$what) =split(/:/,$tail); 1365: if ($namespace ne 'roles') { 1366: chomp($what); 1367: my $hashref = TieResourceHash($udom, $uname, $namespace, 1368: &GDBM_WRCREAT(),"P",$what); 1369: if($hashref) { 1370: my @pairs=split(/\&/,$what); 1371: foreach my $pair (@pairs) { 1372: my ($key,$value)=split(/=/,$pair); 1373: $hashref->{$key}=$value; 1374: } 1375: if (untie(%$hashref)) { 1376: Reply( $client, "ok\n", $userinput); 1377: } else { 1378: Failure($client, "error: ".($!+0)." untie(GDBM) failed ". 1379: "while attempting put\n", 1380: $userinput); 1381: } 1382: } else { 1383: Failure( $client, "error: ".($!)." tie(GDBM) Failed ". 1384: "while attempting put\n", $userinput); 1385: } 1386: } else { 1387: Failure( $client, "refused\n", $userinput); 1388: } 1389: 1390: return 1; 1391: } 1392: RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0); 1393: 1394: # 1395: # Increment a profile entry in the user history file. 1396: # The history contains keyword value pairs. In this case, 1397: # The value itself is a pair of numbers. The first, the current value 1398: # the second an increment that this function applies to the current 1399: # value. 1400: # 1401: # Parameters: 1402: # $cmd - The command that got us here. 1403: # $tail - Tail of the command (remaining parameters). 1404: # $client - File descriptor connected to client. 1405: # Returns 1406: # 0 - Requested to exit, caller should shut down. 1407: # 1 - Continue processing. 1408: # 1409: sub IncrementUserValueHandler { 1410: my $cmd = shift; 1411: my $tail = shift; 1412: my $client = shift; 1413: my $userinput = "$cmd:$tail"; 1414: 1415: my ($udom,$uname,$namespace,$what) =split(/:/,$tail); 1416: if ($namespace ne 'roles') { 1417: chomp($what); 1418: my $hashref = TieResourceHash($udom, $uname, 1419: $namespace, &GDBM_WRCREAT(), 1420: "P",$what); 1421: if ($hashref) { 1422: my @pairs=split(/\&/,$what); 1423: foreach my $pair (@pairs) { 1424: my ($key,$value)=split(/=/,$pair); 1425: # We could check that we have a number... 1426: if (! defined($value) || $value eq '') { 1427: $value = 1; 1428: } 1429: $hashref->{$key}+=$value; 1430: } 1431: if (untie(%$hashref)) { 1432: Reply( $client, "ok\n", $userinput); 1433: } else { 1434: Failure($client, "error: ".($!+0)." untie(GDBM) failed ". 1435: "while attempting inc\n", $userinput); 1436: } 1437: } else { 1438: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 1439: "while attempting inc\n", $userinput); 1440: } 1441: } else { 1442: Failure($client, "refused\n", $userinput); 1443: } 1444: 1445: return 1; 1446: } 1447: RegisterHandler("inc", \&IncrementUserValueHandler, 0, 1, 0); 1448: # 1449: # Put a new role for a user. Roles are LonCAPA's packaging of permissions. 1450: # Each 'role' a user has implies a set of permissions. Adding a new role 1451: # for a person grants the permissions packaged with that role 1452: # to that user when the role is selected. 1453: # 1454: # Parameters: 1455: # $cmd - The command string (rolesput). 1456: # $tail - The remainder of the request line. For rolesput this 1457: # consists of a colon separated list that contains: 1458: # The domain and user that is granting the role (logged). 1459: # The domain and user that is getting the role. 1460: # The roles being granted as a set of & separated pairs. 1461: # each pair a key value pair. 1462: # $client - File descriptor connected to the client. 1463: # Returns: 1464: # 0 - If the daemon should exit 1465: # 1 - To continue processing. 1466: # 1467: # 1468: sub RolesPutHandler { 1469: my $cmd = shift; 1470: my $tail = shift; 1471: my $client = shift; 1472: my $userinput = "$cmd:$tail"; 1473: 1474: my ($exedom,$exeuser,$udom,$uname,$what) =split(/:/,$tail); 1475: &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom. 1476: "what = ".$what); 1477: my $namespace='roles'; 1478: chomp($what); 1479: my $hashref = TieResourceHash($udom, $uname, $namespace, 1480: &GDBM_WRCREAT(), "P", 1481: "$exedom:$exeuser:$what"); 1482: # 1483: # Log the attempt to set a role. The {}'s here ensure that the file 1484: # handle is open for the minimal amount of time. Since the flush 1485: # is done on close this improves the chances the log will be an un- 1486: # corrupted ordered thing. 1487: if ($hashref) { 1488: my @pairs=split(/\&/,$what); 1489: foreach my $pair (@pairs) { 1490: my ($key,$value)=split(/=/,$pair); 1491: &ManagePermissions($key, $udom, $uname, 1492: &GetAuthType( $udom, $uname)); 1493: $hashref->{$key}=$value; 1494: } 1495: if (untie($hashref)) { 1496: Reply($client, "ok\n", $userinput); 1497: } else { 1498: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 1499: "while attempting rolesput\n", $userinput); 1500: } 1501: } else { 1502: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 1503: "while attempting rolesput\n", $userinput); 1504: } 1505: return 1; 1506: } 1507: RegisterHandler("rolesput", \&RolesPutHandler, 1,1,0); # Encoded client only. 1508: # 1509: # Deletes (removes) a role for a user. This is equivalent to removing 1510: # a permissions package associated with the role from the user's profile. 1511: # 1512: # Parameters: 1513: # $cmd - The command (rolesdel) 1514: # $tail - The remainder of the request line. This consists 1515: # of: 1516: # The domain and user requesting the change (logged) 1517: # The domain and user being changed. 1518: # The roles being revoked. These are shipped to us 1519: # as a bunch of & separated role name keywords. 1520: # $client - The file handle open on the client. 1521: # Returns: 1522: # 1 - Continue processing 1523: # 0 - Exit. 1524: # 1525: sub RolesDeleteHandler { 1526: my $cmd = shift; 1527: my $tail = shift; 1528: my $client = shift; 1529: my $userinput = "$cmd:$tail"; 1530: 1531: my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail); 1532: &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom. 1533: "what = ".$what); 1534: my $namespace='roles'; 1535: chomp($what); 1536: my $hashref = TieResourceHash($udom, $uname, $namespace, 1537: &GDBM_WRCREAT(), "D", 1538: "$exedom:$exeuser:$what"); 1539: 1540: if ($hashref) { 1541: my @rolekeys=split(/\&/,$what); 1542: 1543: foreach my $key (@rolekeys) { 1544: delete $hashref->{$key}; 1545: } 1546: if (untie(%$hashref)) { 1547: Reply($client, "ok\n", $userinput); 1548: } else { 1549: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 1550: "while attempting rolesdel\n", $userinput); 1551: } 1552: } else { 1553: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 1554: "while attempting rolesdel\n", $userinput); 1555: } 1556: 1557: return 1; 1558: } 1559: RegisterHandler("rolesdel", \&RolesDeleteHandler, 1,1, 0); # Encoded client only 1560: 1561: # Unencrypted get from a user's profile database. See 1562: # GetProfileEntryEncrypted for a version that does end-to-end encryption. 1563: # This function retrieves a keyed item from a specific named database in the 1564: # user's directory. 1565: # 1566: # Parameters: 1567: # $cmd - Command request keyword (get). 1568: # $tail - Tail of the command. This is a colon separated list 1569: # consisting of the domain and username that uniquely 1570: # identifies the profile, 1571: # The 'namespace' which selects the gdbm file to 1572: # do the lookup in, 1573: # & separated list of keys to lookup. Note that 1574: # the values are returned as an & separated list too. 1575: # $client - File descriptor open on the client. 1576: # Returns: 1577: # 1 - Continue processing. 1578: # 0 - Exit. 1579: # 1580: sub GetProfileEntry { 1581: my $cmd = shift; 1582: my $tail = shift; 1583: my $client = shift; 1584: my $userinput= "$cmd:$tail"; 1585: 1586: my ($udom,$uname,$namespace,$what) = split(/:/,$tail); 1587: chomp($what); 1588: my $hashref = TieResourceHash($udom, $uname, $namespace, 1589: &GDBM_READER()); 1590: if ($hashref) { 1591: my @queries=split(/\&/,$what); 1592: my $qresult=''; 1593: 1594: for (my $i=0;$i<=$#queries;$i++) { 1595: $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. 1596: } 1597: $qresult=~s/\&$//; # Remove trailing & from last lookup. 1598: if (untie(%$hashref)) { 1599: Reply($client, "$qresult\n", $userinput); 1600: } else { 1601: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 1602: "while attempting get\n", $userinput); 1603: } 1604: } else { 1605: if ($!+0 == 2) { # +0 coerces errno -> number 2 is ENOENT 1606: Failure($client, "error:No such file or ". 1607: "GDBM reported bad block error\n", $userinput); 1608: } else { # Some other undifferentiated err. 1609: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 1610: "while attempting get\n", $userinput); 1611: } 1612: } 1613: return 1; 1614: } 1615: RegisterHandler("get", \&GetProfileEntry, 0,1,0); 1616: # 1617: # Process the encrypted get request. Note that the request is sent 1618: # in clear, but the reply is encrypted. This is a small covert channel: 1619: # information about the sensitive keys is given to the snooper. Just not 1620: # information about the values of the sensitive key. Hmm if I wanted to 1621: # know these I'd snoop for the egets. Get the profile item names from them 1622: # and then issue a get for them since there's no enforcement of the 1623: # requirement of an encrypted get for particular profile items. If I 1624: # were re-doing this, I'd force the request to be encrypted as well as the 1625: # reply. I'd also just enforce encrypted transactions for all gets since 1626: # that would prevent any covert channel snooping. 1627: # 1628: # Parameters: 1629: # $cmd - Command keyword of request (eget). 1630: # $tail - Tail of the command. See GetProfileEntry # for more information about this. 1631: # $client - File open on the client. 1632: # Returns: 1633: # 1 - Continue processing 1634: # 0 - server should exit. 1635: sub GetProfileEntryEncrypted { 1636: my $cmd = shift; 1637: my $tail = shift; 1638: my $client = shift; 1639: my $userinput = "$cmd:$tail"; 1640: 1641: my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput); 1642: chomp($what); 1643: my $hashref = TieResourceHash($udom, $uname, $namespace, 1644: &GDBM_READER()); 1645: if ($hashref) { 1646: my @queries=split(/\&/,$what); 1647: my $qresult=''; 1648: for (my $i=0;$i<=$#queries;$i++) { 1649: $qresult.="$hashref->{$queries[$i]}&"; 1650: } 1651: if (untie(%$hashref)) { 1652: $qresult=~s/\&$//; 1653: if ($cipher) { 1654: my $cmdlength=length($qresult); 1655: $qresult.=" "; 1656: my $encqresult=''; 1657: for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { 1658: $encqresult.= unpack("H16", $cipher->encrypt(substr($qresult, 1659: $encidx, 1660: 8))); 1661: } 1662: Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput); 1663: } else { 1664: Failure( $client, "error:no_key\n", $userinput); 1665: } 1666: } else { 1667: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 1668: "while attempting eget\n", $userinput); 1669: } 1670: } else { 1671: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 1672: "while attempting eget\n", $userinput); 1673: } 1674: 1675: return 1; 1676: } 1677: RegisterHandler("eget", \&GetProfileEncrypted, 0, 1, 0); 1678: 1679: # 1680: # Deletes a key in a user profile database. 1681: # 1682: # Parameters: 1683: # $cmd - Command keyword (del). 1684: # $tail - Command tail. IN this case a colon 1685: # separated list containing: 1686: # The domain and user that identifies uniquely 1687: # the identity of the user. 1688: # The profile namespace (name of the profile 1689: # database file). 1690: # & separated list of keywords to delete. 1691: # $client - File open on client socket. 1692: # Returns: 1693: # 1 - Continue processing 1694: # 0 - Exit server. 1695: # 1696: # 1697: 1698: sub DeleteProfileEntry { 1699: my $cmd = shift; 1700: my $tail = shift; 1701: my $client = shift; 1702: my $userinput = "cmd:$tail"; 1703: 1704: my ($udom,$uname,$namespace,$what) = split(/:/,$tail); 1705: chomp($what); 1706: my $hashref = TieResourceHash($udom, $uname, $namespace, 1707: &GDBM_WRCREAT(), 1708: "D",$what); 1709: if ($hashref) { 1710: my @keys=split(/\&/,$what); 1711: foreach my $key (@keys) { 1712: delete($hashref->{$key}); 1713: } 1714: if (untie(%$hashref)) { 1715: Reply($client, "ok\n", $userinput); 1716: } else { 1717: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 1718: "while attempting del\n", $userinput); 1719: } 1720: } else { 1721: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 1722: "while attempting del\n", $userinput); 1723: } 1724: return 1; 1725: } 1726: RegisterHandler("del", \&DeleteProfileEntry, 0, 1, 0); 1727: # 1728: # List the set of keys that are defined in a profile database file. 1729: # A successful reply from this will contain an & separated list of 1730: # the keys. 1731: # Parameters: 1732: # $cmd - Command request (keys). 1733: # $tail - Remainder of the request, a colon separated 1734: # list containing domain/user that identifies the 1735: # user being queried, and the database namespace 1736: # (database filename essentially). 1737: # $client - File open on the client. 1738: # Returns: 1739: # 1 - Continue processing. 1740: # 0 - Exit the server. 1741: # 1742: sub GetProfileKeys { 1743: my $cmd = shift; 1744: my $tail = shift; 1745: my $client = shift; 1746: my $userinput = "$cmd:$tail"; 1747: 1748: my ($udom,$uname,$namespace)=split(/:/,$tail); 1749: my $qresult=''; 1750: my $hashref = TieResourceHash($udom, $uname, $namespace, 1751: &GDBM_READER()); 1752: if ($hashref) { 1753: foreach my $key (keys %$hashref) { 1754: $qresult.="$key&"; 1755: } 1756: if (untie(%$hashref)) { 1757: $qresult=~s/\&$//; 1758: Reply($client, "$qresult\n", $userinput); 1759: } else { 1760: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 1761: "while attempting keys\n", $userinput); 1762: } 1763: } else { 1764: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 1765: "while attempting keys\n", $userinput); 1766: } 1767: 1768: return 1; 1769: } 1770: RegisterHandler("keys", \&GetProfileKeys, 0, 1, 0); 1771: # 1772: # Dump the contents of a user profile database. 1773: # Note that this constitutes a very large covert channel too since 1774: # the dump will return sensitive information that is not encrypted. 1775: # The naive security assumption is that the session negotiation ensures 1776: # our client is trusted and I don't believe that's assured at present. 1777: # Sure want badly to go to ssl or tls. Of course if my peer isn't really 1778: # a LonCAPA node they could have negotiated an encryption key too so >sigh<. 1779: # 1780: # Parameters: 1781: # $cmd - The command request keyword (currentdump). 1782: # $tail - Remainder of the request, consisting of a colon 1783: # separated list that has the domain/username and 1784: # the namespace to dump (database file). 1785: # $client - file open on the remote client. 1786: # Returns: 1787: # 1 - Continue processing. 1788: # 0 - Exit the server. 1789: # 1790: sub DumpProfileDatabase { 1791: my $cmd = shift; 1792: my $tail = shift; 1793: my $client = shift; 1794: my $userinput = "$cmd:$tail"; 1795: 1796: my ($udom,$uname,$namespace) = split(/:/,$tail); 1797: my $hashref = TieResourceHash($udom, $uname, $namespace, 1798: &GDBM_READER()); 1799: if ($hashref) { 1800: # Structure of %data: 1801: # $data{$symb}->{$parameter}=$value; 1802: # $data{$symb}->{'v.'.$parameter}=$version; 1803: # since $parameter will be unescaped, we do not 1804: # have to worry about silly parameter names... 1805: 1806: my $qresult=''; 1807: my %data = (); # A hash of anonymous hashes.. 1808: while (my ($key,$value) = each(%$hashref)) { 1809: my ($v,$symb,$param) = split(/:/,$key); 1810: next if ($v eq 'version' || $symb eq 'keys'); 1811: next if (exists($data{$symb}) && 1812: exists($data{$symb}->{$param}) && 1813: $data{$symb}->{'v.'.$param} > $v); 1814: $data{$symb}->{$param}=$value; 1815: $data{$symb}->{'v.'.$param}=$v; 1816: } 1817: if (untie(%$hashref)) { 1818: while (my ($symb,$param_hash) = each(%data)) { 1819: while(my ($param,$value) = each (%$param_hash)){ 1820: next if ($param =~ /^v\./); # Ignore versions... 1821: # 1822: # Just dump the symb=value pairs separated by & 1823: # 1824: $qresult.=$symb.':'.$param.'='.$value.'&'; 1825: } 1826: } 1827: chop($qresult); 1828: Reply($client , "$qresult\n", $userinput); 1829: } else { 1830: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 1831: "while attempting currentdump\n", $userinput); 1832: } 1833: } else { 1834: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 1835: "while attempting currentdump\n", $userinput); 1836: } 1837: 1838: return 1; 1839: } 1840: RegisterHandler("currentdump", \&DumpProfileDatabase, 0, 1, 0); 1841: # 1842: # Dump a profile database with an optional regular expression 1843: # to match against the keys. In this dump, no effort is made 1844: # to separate symb from version information. Presumably the 1845: # databases that are dumped by this command are of a different 1846: # structure. Need to look at this and improve the documentation of 1847: # both this and the currentdump handler. 1848: # Parameters: 1849: # $cmd - The command keyword. 1850: # $tail - All of the characters after the $cmd: 1851: # These are expected to be a colon 1852: # separated list containing: 1853: # domain/user - identifying the user. 1854: # namespace - identifying the database. 1855: # regexp - optional regular expression 1856: # that is matched against 1857: # database keywords to do 1858: # selective dumps. 1859: # $client - Channel open on the client. 1860: # Returns: 1861: # 1 - Continue processing. 1862: # Side effects: 1863: # response is written to $client. 1864: # 1865: sub DumpWithRegexp { 1866: my $cmd = shift; 1867: my $tail = shift; 1868: my $client = shift; 1869: 1870: my $userinput = "$cmd:$tail"; 1871: 1872: my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); 1873: if (defined($regexp)) { 1874: $regexp=&unescape($regexp); 1875: } else { 1876: $regexp='.'; 1877: } 1878: my $hashref =TieResourceHash($udom, $uname, $namespace, 1879: &GDBM_READER()); 1880: if ($hashref) { 1881: my $qresult=''; 1882: while (my ($key,$value) = each(%$hashref)) { 1883: if ($regexp eq '.') { 1884: $qresult.=$key.'='.$value.'&'; 1885: } else { 1886: my $unescapeKey = &unescape($key); 1887: if (eval('$unescapeKey=~/$regexp/')) { 1888: $qresult.="$key=$value&"; 1889: } 1890: } 1891: } 1892: if (untie(%$hashref)) { 1893: chop($qresult); 1894: Reply($client, "$qresult\n", $userinput); 1895: } else { 1896: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 1897: "while attempting dump\n", $userinput); 1898: } 1899: } else { 1900: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 1901: "while attempting dump\n", $userinput); 1902: } 1903: 1904: return 1; 1905: } 1906: RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0); 1907: 1908: # Store an aitem in any database but the roles database. 1909: # 1910: # Parameters: 1911: # $cmd - Request command keyword. 1912: # $tail - Tail of the request. This is a colon 1913: # separated list containing: 1914: # domain/user - User and authentication domain. 1915: # namespace - Name of the database being modified 1916: # rid - Resource keyword to modify. 1917: # what - new value associated with rid. 1918: # 1919: # $client - Socket open on the client. 1920: # 1921: # 1922: # Returns: 1923: # 1 (keep on processing). 1924: # Side-Effects: 1925: # Writes to the client 1926: sub StoreHandler { 1927: my $cmd = shift; 1928: my $tail = shift; 1929: my $client = shift; 1930: 1931: my $userinput = "$cmd:$tail"; 1932: 1933: my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail); 1934: if ($namespace ne 'roles') { 1935: 1936: chomp($what); 1937: my @pairs=split(/\&/,$what); 1938: my $hashref = TieResourceHash($udom, $uname, $namespace, 1939: &GDBM_WRCREAT(), "P", 1940: "$rid:$what"); 1941: if ($hashref) { 1942: my $now = time; 1943: my @previouskeys=split(/&/,$hashref->{"keys:$rid"}); 1944: my $key; 1945: $hashref->{"version:$rid"}++; 1946: my $version=$hashref->{"version:$rid"}; 1947: my $allkeys=''; 1948: foreach my $pair (@pairs) { 1949: my ($key,$value)=split(/=/,$pair); 1950: $allkeys.=$key.':'; 1951: $hashref->{"$version:$rid:$key"}=$value; 1952: } 1953: $hashref->{"$version:$rid:timestamp"}=$now; 1954: $allkeys.='timestamp'; 1955: $hashref->{"$version:keys:$rid"}=$allkeys; 1956: if (untie($hashref)) { 1957: Reply($client, "ok\n", $userinput); 1958: } else { 1959: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 1960: "while attempting store\n", $userinput); 1961: } 1962: } else { 1963: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 1964: "while attempting store\n", $userinput); 1965: } 1966: } else { 1967: Failure($client, "refused\n", $userinput); 1968: } 1969: 1970: return 1; 1971: } 1972: RegisterHandler("store", \&StoreHandler, 0, 1, 0); 1973: # 1974: # Restore a prior version of a resource. 1975: # 1976: # Parameters: 1977: # $cmd - Command keyword. 1978: # $tail - Remainder of the request which consists of: 1979: # domain/user - User and auth. domain. 1980: # namespace - name of resource database. 1981: # rid - Resource id. 1982: # $client - socket open on the client. 1983: # 1984: # Returns: 1985: # 1 indicating the caller should not yet exit. 1986: # Side-effects: 1987: # Writes a reply to the client. 1988: # 1989: sub RestoreHandler { 1990: my $cmd = shift; 1991: my $tail = shift; 1992: my $client = shift; 1993: 1994: my $userinput = "$cmd:$tail"; # Only used for logging purposes. 1995: 1996: my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput); 1997: $namespace=~s/\//\_/g; 1998: $namespace=~s/\W//g; 1999: chomp($rid); 2000: my $proname=propath($udom,$uname); 2001: my $qresult=''; 2002: my %hash; 2003: if (tie(%hash,'GDBM_File',"$proname/$namespace.db", 2004: &GDBM_READER(),0640)) { 2005: my $version=$hash{"version:$rid"}; 2006: $qresult.="version=$version&"; 2007: my $scope; 2008: for ($scope=1;$scope<=$version;$scope++) { 2009: my $vkeys=$hash{"$scope:keys:$rid"}; 2010: my @keys=split(/:/,$vkeys); 2011: my $key; 2012: $qresult.="$scope:keys=$vkeys&"; 2013: foreach $key (@keys) { 2014: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; 2015: } 2016: } 2017: if (untie(%hash)) { 2018: $qresult=~s/\&$//; 2019: Reply( $client, "$qresult\n", $userinput); 2020: } else { 2021: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2022: "while attempting restore\n", $userinput); 2023: } 2024: } else { 2025: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2026: "while attempting restore\n", $userinput); 2027: } 2028: 2029: return 1; 2030: 2031: 2032: } 2033: RegisterHandler("restore", \&RestoreHandler, 0,1,0); 2034: 2035: # 2036: # Add a chat message to to a discussion board. 2037: # 2038: # Parameters: 2039: # $cmd - Request keyword. 2040: # $tail - Tail of the command. A colon separated list 2041: # containing: 2042: # cdom - Domain on which the chat board lives 2043: # cnum - Identifier of the discussion group. 2044: # post - Body of the posting. 2045: # $client - Socket open on the client. 2046: # Returns: 2047: # 1 - Indicating caller should keep on processing. 2048: # 2049: # Side-effects: 2050: # writes a reply to the client. 2051: # 2052: # 2053: sub SendChatHandler { 2054: my $cmd = shift; 2055: my $tail = shift; 2056: my $client = shift; 2057: 2058: my $userinput = "$cmd:$tail"; 2059: 2060: my ($cdom,$cnum,$newpost)=split(/\:/,$tail); 2061: &chatadd($cdom,$cnum,$newpost); 2062: Reply($client, "ok\n", $userinput); 2063: 2064: return 1; 2065: } 2066: RegisterHandler("chatsend", \&SendChatHandler, 0, 1, 0); 2067: # 2068: # Retrieve the set of chat messagss from a discussion board. 2069: # 2070: # Parameters: 2071: # $cmd - Command keyword that initiated the request. 2072: # $tail - Remainder of the request after the command 2073: # keyword. In this case a colon separated list of 2074: # chat domain - Which discussion board. 2075: # chat id - Discussion thread(?) 2076: # domain/user - Authentication domain and username 2077: # of the requesting person. 2078: # $client - Socket open on the client program. 2079: # Returns: 2080: # 1 - continue processing 2081: # Side effects: 2082: # Response is written to the client. 2083: # 2084: sub RetrieveChatHandler { 2085: my $cmd = shift; 2086: my $tail = shift; 2087: my $client = shift; 2088: 2089: my $userinput = "$cmd:$tail"; 2090: 2091: my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail); 2092: my $reply=''; 2093: foreach (&getchat($cdom,$cnum,$udom,$uname)) { 2094: $reply.=&escape($_).':'; 2095: } 2096: $reply=~s/\:$//; 2097: Reply($client, $reply."\n", $userinput); 2098: 2099: 2100: return 1; 2101: } 2102: RegisterHandler("chatretr", \&RetrieveChatHandler, 0, 1, 0); 2103: # 2104: # Initiate a query of an sql database. SQL query repsonses get put in 2105: # a file for later retrieval. This prevents sql query results from 2106: # bottlenecking the system. Note that with loncnew, perhaps this is 2107: # less of an issue since multiple outstanding requests can be concurrently 2108: # serviced. 2109: # 2110: # Parameters: 2111: # $cmd - COmmand keyword that initiated the request. 2112: # $tail - Remainder of the command after the keyword. 2113: # For this function, this consists of a query and 2114: # 3 arguments that are self-documentingly labelled 2115: # in the original arg1, arg2, arg3. 2116: # $client - Socket open on the client. 2117: # Return: 2118: # 1 - Indicating processing should continue. 2119: # Side-effects: 2120: # a reply is written to $client. 2121: # 2122: sub SendQueryHandler { 2123: my $cmd = shift; 2124: my $tail = shift; 2125: my $client = shift; 2126: 2127: my $userinput = "$cmd:$tail"; 2128: 2129: my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail); 2130: $query=~s/\n*$//g; 2131: Reply($client, "". sqlreply("$clientname\&$query". 2132: "\&$arg1"."\&$arg2"."\&$arg3")."\n", 2133: $userinput); 2134: 2135: return 1; 2136: } 2137: RegisterHandler("querysend", \&SendQueryHandler, 0, 1, 0); 2138: 2139: # 2140: # Add a reply to an sql query. SQL queries are done asyncrhonously. 2141: # The query is submitted via a "querysend" transaction. 2142: # There it is passed on to the lonsql daemon, queued and issued to 2143: # mysql. 2144: # This transaction is invoked when the sql transaction is complete 2145: # it stores the query results in flie and indicates query completion. 2146: # presumably local software then fetches this response... I'm guessing 2147: # the sequence is: lonc does a querysend, we ask lonsql to do it. 2148: # lonsql on completion of the query interacts with the lond of our 2149: # client to do a query reply storing two files: 2150: # - id - The results of the query. 2151: # - id.end - Indicating the transaction completed. 2152: # NOTE: id is a unique id assigned to the query and querysend time. 2153: # Parameters: 2154: # $cmd - Command keyword that initiated this request. 2155: # $tail - Remainder of the tail. In this case that's a colon 2156: # separated list containing the query Id and the 2157: # results of the query. 2158: # $client - Socket open on the client. 2159: # Return: 2160: # 1 - Indicating that we should continue processing. 2161: # Side effects: 2162: # ok written to the client. 2163: # 2164: sub ReplyQueryHandler { 2165: my $cmd = shift; 2166: my $tail = shift; 2167: my $client = shift; 2168: 2169: my $userinput = "$cmd:$tail"; 2170: 2171: my ($cmd,$id,$reply)=split(/:/,$userinput); 2172: my $store; 2173: my $execdir=$perlvar{'lonDaemons'}; 2174: if ($store=IO::File->new(">$execdir/tmp/$id")) { 2175: $reply=~s/\&/\n/g; 2176: print $store $reply; 2177: close $store; 2178: my $store2=IO::File->new(">$execdir/tmp/$id.end"); 2179: print $store2 "done\n"; 2180: close $store2; 2181: Reply($client, "ok\n", $userinput); 2182: } else { 2183: Failure($client, "error: ".($!+0) 2184: ." IO::File->new Failed ". 2185: "while attempting queryreply\n", $userinput); 2186: } 2187: 2188: 2189: return 1; 2190: } 2191: RegisterHandler("queryreply", \&ReplyQueryHandler, 0, 1, 0); 2192: # 2193: # Process the courseidput query. Not quite sure what this means 2194: # at the system level sense. It appears a gdbm file in the 2195: # /home/httpd/lonUsers/$domain/nohist_courseids is tied and 2196: # a set of entries made in that database. 2197: # 2198: # Parameters: 2199: # $cmd - The command keyword that initiated this request. 2200: # $tail - Tail of the command. In this case consists of a colon 2201: # separated list contaning the domain to apply this to and 2202: # an ampersand separated list of keyword=value pairs. 2203: # $client - Socket open on the client. 2204: # Returns: 2205: # 1 - indicating that processing should continue 2206: # 2207: # Side effects: 2208: # reply is written to the client. 2209: # 2210: sub PutCourseIdHandler { 2211: my $cmd = shift; 2212: my $tail = shift; 2213: my $client = shift; 2214: 2215: my $userinput = "$cmd:$tail"; 2216: 2217: my ($udom,$what)=split(/:/,$tail); 2218: chomp($what); 2219: $udom=~s/\W//g; 2220: my $proname= 2221: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; 2222: my $now=time; 2223: my @pairs=split(/\&/,$what); 2224: my %hash; 2225: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { 2226: foreach my $pair (@pairs) { 2227: my ($key,$value)=split(/=/,$pair); 2228: $hash{$key}=$value.':'.$now; 2229: } 2230: if (untie(%hash)) { 2231: Reply($client, "ok\n", $userinput); 2232: } else { 2233: Failure( $client, "error: ".($!+0) 2234: ." untie(GDBM) Failed ". 2235: "while attempting courseidput\n", $userinput); 2236: } 2237: } else { 2238: Failure( $client, "error: ".($!+0) 2239: ." tie(GDBM) Failed ". 2240: "while attempting courseidput\n", $userinput); 2241: } 2242: 2243: return 1; 2244: } 2245: RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0); 2246: 2247: # Retrieves the value of a course id resource keyword pattern 2248: # defined since a starting date. Both the starting date and the 2249: # keyword pattern are optional. If the starting date is not supplied it 2250: # is treated as the beginning of time. If the pattern is not found, 2251: # it is treatred as "." matching everything. 2252: # 2253: # Parameters: 2254: # $cmd - Command keyword that resulted in us being dispatched. 2255: # $tail - The remainder of the command that, in this case, consists 2256: # of a colon separated list of: 2257: # domain - The domain in which the course database is 2258: # defined. 2259: # since - Optional parameter describing the minimum 2260: # time of definition(?) of the resources that 2261: # will match the dump. 2262: # description - regular expression that is used to filter 2263: # the dump. Only keywords matching this regexp 2264: # will be used. 2265: # $client - The socket open on the client. 2266: # Returns: 2267: # 1 - Continue processing. 2268: # Side Effects: 2269: # a reply is written to $client. 2270: sub DumpCourseIdHandler { 2271: my $cmd = shift; 2272: my $tail = shift; 2273: my $client = shift; 2274: 2275: my $userinput = "$cmd:$tail"; 2276: 2277: my ($udom,$since,$description) =split(/:/,$tail); 2278: if (defined($description)) { 2279: $description=&unescape($description); 2280: } else { 2281: $description='.'; 2282: } 2283: unless (defined($since)) { $since=0; } 2284: my $qresult=''; 2285: my $proname = "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; 2286: my %hash; 2287: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { 2288: while (my ($key,$value) = each(%hash)) { 2289: my ($descr,$lasttime)=split(/\:/,$value); 2290: if ($lasttime<$since) { 2291: next; 2292: } 2293: if ($description eq '.') { 2294: $qresult.=$key.'='.$descr.'&'; 2295: } else { 2296: my $unescapeVal = &unescape($descr); 2297: if (eval('$unescapeVal=~/$description/i')) { 2298: $qresult.="$key=$descr&"; 2299: } 2300: } 2301: } 2302: if (untie(%hash)) { 2303: chop($qresult); 2304: Reply($client, "$qresult\n", $userinput); 2305: } else { 2306: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2307: "while attempting courseiddump\n", $userinput); 2308: } 2309: } else { 2310: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2311: "while attempting courseiddump\n", $userinput); 2312: } 2313: 2314: 2315: return 1; 2316: } 2317: RegisterHandler("courseiddump", \&DumpCourseIdHandler, 0, 1, 0); 2318: # 2319: # Puts an id to a domains id database. 2320: # 2321: # Parameters: 2322: # $cmd - The command that triggered us. 2323: # $tail - Remainder of the request other than the command. This is a 2324: # colon separated list containing: 2325: # $domain - The domain for which we are writing the id. 2326: # $pairs - The id info to write... this is and & separated list 2327: # of keyword=value. 2328: # $client - Socket open on the client. 2329: # Returns: 2330: # 1 - Continue processing. 2331: # Side effects: 2332: # reply is written to $client. 2333: # 2334: sub PutIdHandler { 2335: my $cmd = shift; 2336: my $tail = shift; 2337: my $client = shift; 2338: 2339: my $userinput = "$cmd:$tail"; 2340: 2341: my ($udom,$what)=split(/:/,$tail); 2342: chomp($what); 2343: $udom=~s/\W//g; 2344: my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; 2345: my $now=time; 2346: { 2347: my $hfh; 2348: if ($hfh=IO::File->new(">>$proname.hist")) { 2349: print $hfh "P:$now:$what\n"; 2350: } 2351: } 2352: my @pairs=split(/\&/,$what); 2353: my %hash; 2354: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { 2355: foreach my $pair (@pairs) { 2356: my ($key,$value)=split(/=/,$pair); 2357: $hash{$key}=$value; 2358: } 2359: if (untie(%hash)) { 2360: Reply($client, "ok\n", $userinput); 2361: } else { 2362: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2363: "while attempting idput\n", $userinput); 2364: } 2365: } else { 2366: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2367: "while attempting idput\n", $userinput); 2368: } 2369: 2370: return 1; 2371: } 2372: 2373: RegisterHandler("idput", \&PutIdHandler, 0, 1, 0); 2374: # 2375: # Retrieves a set of id values from the id database. 2376: # Returns an & separated list of results, one for each requested id to the 2377: # client. 2378: # 2379: # Parameters: 2380: # $cmd - Command keyword that caused us to be dispatched. 2381: # $tail - Tail of the command. Consists of a colon separated: 2382: # domain - the domain whose id table we dump 2383: # ids Consists of an & separated list of 2384: # id keywords whose values will be fetched. 2385: # nonexisting keywords will have an empty value. 2386: # $client - Socket open on the client. 2387: # 2388: # Returns: 2389: # 1 - indicating processing should continue. 2390: # Side effects: 2391: # An & separated list of results is written to $client. 2392: # 2393: sub GetIdHandler { 2394: my $cmd = shift; 2395: my $tail = shift; 2396: my $client = shift; 2397: 2398: my $userinput = "$client:$tail"; 2399: 2400: my ($udom,$what)=split(/:/,$tail); 2401: chomp($what); 2402: $udom=~s/\W//g; 2403: my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; 2404: my @queries=split(/\&/,$what); 2405: my $qresult=''; 2406: my %hash; 2407: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { 2408: for (my $i=0;$i<=$#queries;$i++) { 2409: $qresult.="$hash{$queries[$i]}&"; 2410: } 2411: if (untie(%hash)) { 2412: $qresult=~s/\&$//; 2413: Reply($client, "$qresult\n", $userinput); 2414: } else { 2415: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 2416: "while attempting idget\n",$userinput); 2417: } 2418: } else { 2419: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2420: "while attempting idget\n",$userinput); 2421: } 2422: 2423: return 1; 2424: } 2425: 2426: RegisterHandler("idget", \&GetIdHandler, 0, 1, 0); 2427: # 2428: # Process the tmpput command I'm not sure what this does.. Seems to 2429: # create a file in the lonDaemons/tmp directory of the form $id.tmp 2430: # where Id is the client's ip concatenated with a sequence number. 2431: # The file will contain some value that is passed in. Is this e.g. 2432: # a login token? 2433: # 2434: # Parameters: 2435: # $cmd - The command that got us dispatched. 2436: # $tail - The remainder of the request following $cmd: 2437: # In this case this will be the contents of the file. 2438: # $client - Socket connected to the client. 2439: # Returns: 2440: # 1 indicating processing can continue. 2441: # Side effects: 2442: # A file is created in the local filesystem. 2443: # A reply is sent to the client. 2444: sub TmpPutHandler { 2445: my $cmd = shift; 2446: my $what = shift; 2447: my $client = shift; 2448: 2449: my $userinput = "$cmd:$what"; # Reconstruct for logging. 2450: 2451: 2452: my $store; 2453: $tmpsnum++; 2454: my $id=$$.'_'.$clientip.'_'.$tmpsnum; 2455: $id=~s/\W/\_/g; 2456: $what=~s/\n//g; 2457: my $execdir=$perlvar{'lonDaemons'}; 2458: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { 2459: print $store $what; 2460: close $store; 2461: Reply($client, "$id\n", $userinput); 2462: } else { 2463: Failure( $client, "error: ".($!+0)."IO::File->new Failed ". 2464: "while attempting tmpput\n", $userinput); 2465: } 2466: return 1; 2467: 2468: } 2469: RegisterHandler("tmpput", \&TmpPutHandler, 0, 1, 0); 2470: 2471: # Processes the tmpget command. This command returns the contents 2472: # of a temporary resource file(?) created via tmpput. 2473: # 2474: # Paramters: 2475: # $cmd - Command that got us dispatched. 2476: # $id - Tail of the command, contain the id of the resource 2477: # we want to fetch. 2478: # $client - socket open on the client. 2479: # Return: 2480: # 1 - Inidcating processing can continue. 2481: # Side effects: 2482: # A reply is sent to the client. 2483: 2484: # 2485: sub TmpGetHandler { 2486: my $cmd = shift; 2487: my $id = shift; 2488: my $client = shift; 2489: my $userinput = "$cmd:$id"; 2490: 2491: chomp($id); 2492: $id=~s/\W/\_/g; 2493: my $store; 2494: my $execdir=$perlvar{'lonDaemons'}; 2495: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { 2496: my $reply=<$store>; 2497: Reply( $client, "$reply\n", $userinput); 2498: close $store; 2499: } else { 2500: Failure( $client, "error: ".($!+0)."IO::File->new Failed ". 2501: "while attempting tmpget\n", $userinput); 2502: } 2503: 2504: return 1; 2505: } 2506: RegisterHandler("tmpget", \&TmpGetHandler, 0, 1, 0); 2507: # 2508: # Process the tmpdel command. This command deletes a temp resource 2509: # created by the tmpput command. 2510: # 2511: # Parameters: 2512: # $cmd - Command that got us here. 2513: # $id - Id of the temporary resource created. 2514: # $client - socket open on the client process. 2515: # 2516: # Returns: 2517: # 1 - Indicating processing should continue. 2518: # Side Effects: 2519: # A file is deleted 2520: # A reply is sent to the client. 2521: sub TmpDelHandler { 2522: my $cmd = shift; 2523: my $id = shift; 2524: my $client = shift; 2525: 2526: my $userinput= "$cmd:$id"; 2527: 2528: chomp($id); 2529: $id=~s/\W/\_/g; 2530: my $execdir=$perlvar{'lonDaemons'}; 2531: if (unlink("$execdir/tmp/$id.tmp")) { 2532: Reply($client, "ok\n", $userinput); 2533: } else { 2534: Failure( $client, "error: ".($!+0)."Unlink tmp Failed ". 2535: "while attempting tmpdel\n", $userinput); 2536: } 2537: 2538: return 1; 2539: 2540: } 2541: RegisterHandler("tmpdel", \&TmpDelHandler, 0, 1, 0); 2542: # 2543: # ls - list the contents of a directory. For each file in the 2544: # selected directory the filename followed by the full output of 2545: # the stat function is returned. The returned info for each 2546: # file are separated by ':'. The stat fields are separated by &'s. 2547: # Parameters: 2548: # $cmd - The command that dispatched us (ls). 2549: # $ulsdir - The directory path to list... I'm not sure what this 2550: # is relative as things like ls:. return e.g. 2551: # no_such_dir. 2552: # $client - Socket open on the client. 2553: # Returns: 2554: # 1 - indicating that the daemon should not disconnect. 2555: # Side Effects: 2556: # The reply is written to $client. 2557: # 2558: sub LsHandler { 2559: my $cmd = shift; 2560: my $ulsdir = shift; 2561: my $client = shift; 2562: 2563: my $userinput = "$cmd:$ulsdir"; 2564: 2565: my $ulsout=''; 2566: my $ulsfn; 2567: if (-e $ulsdir) { 2568: if(-d $ulsdir) { 2569: if (opendir(LSDIR,$ulsdir)) { 2570: while ($ulsfn=readdir(LSDIR)) { 2571: my @ulsstats=stat($ulsdir.'/'.$ulsfn); 2572: $ulsout.=$ulsfn.'&'. 2573: join('&',@ulsstats).':'; 2574: } 2575: closedir(LSDIR); 2576: } 2577: } else { 2578: my @ulsstats=stat($ulsdir); 2579: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; 2580: } 2581: } else { 2582: $ulsout='no_such_dir'; 2583: } 2584: if ($ulsout eq '') { $ulsout='empty'; } 2585: Reply($client, "$ulsout\n", $userinput); 2586: 2587: 2588: return 1; 2589: } 2590: RegisterHandler("ls", \&LsHandler, 0, 1, 0); 2591: 2592: 2593: # 2594: # Processes the setannounce command. This command 2595: # creates a file named announce.txt in the top directory of 2596: # the documentn root and sets its contents. The announce.txt file is 2597: # printed in its entirety at the LonCAPA login page. Note: 2598: # once the announcement.txt fileis created it cannot be deleted. 2599: # However, setting the contents of the file to empty removes the 2600: # announcement from the login page of loncapa so who cares. 2601: # 2602: # Parameters: 2603: # $cmd - The command that got us dispatched. 2604: # $announcement - The text of the announcement. 2605: # $client - Socket open on the client process. 2606: # Retunrns: 2607: # 1 - Indicating request processing should continue 2608: # Side Effects: 2609: # The file {DocRoot}/announcement.txt is created. 2610: # A reply is sent to $client. 2611: # 2612: sub SetAnnounceHandler { 2613: my $cmd = shift; 2614: my $announcement = shift; 2615: my $client = shift; 2616: 2617: my $userinput = "$cmd:$announcement"; 2618: 2619: chomp($announcement); 2620: $announcement=&unescape($announcement); 2621: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. 2622: '/announcement.txt')) { 2623: print $store $announcement; 2624: close $store; 2625: Reply($client, "ok\n", $userinput); 2626: } else { 2627: Failure($client, "error: ".($!+0)."\n", $userinput); 2628: } 2629: 2630: return 1; 2631: } 2632: RegisterHandler("setannounce", \&SetAnnounceHandler, 0, 1, 0); 2633: 2634: # 2635: # Return the version of the daemon. This can be used to determine 2636: # the compatibility of cross version installations or, alternatively to 2637: # simply know who's out of date and who isn't. Note that the version 2638: # is returned concatenated with the tail. 2639: # Parameters: 2640: # $cmd - the request that dispatched to us. 2641: # $tail - Tail of the request (client's version?). 2642: # $client - Socket open on the client. 2643: #Returns: 2644: # 1 - continue processing requests. 2645: # Side Effects: 2646: # Replies with version to $client. 2647: sub GetVersionHandler { 2648: my $client = shift; 2649: my $tail = shift; 2650: my $client = shift; 2651: my $userinput = $client; 2652: 2653: Reply($client, &version($userinput)."\n", $userinput); 2654: 2655: 2656: return 1; 2657: } 2658: RegisterHandler("version", \&GetVersionHandler, 0, 1, 0); 2659: 2660: # Set the current host and domain. This is used to support 2661: # multihomed systems. Each IP of the system, or even separate daemons 2662: # on the same IP can be treated as handling a separate lonCAPA virtual 2663: # machine. This command selects the virtual lonCAPA. The client always 2664: # knows the right one since it is lonc and it is selecting the domain/system 2665: # from the hosts.tab file. 2666: # Parameters: 2667: # $cmd - Command that dispatched us. 2668: # $tail - Tail of the command (domain/host requested). 2669: # $socket - Socket open on the client. 2670: # 2671: # Returns: 2672: # 1 - Indicates the program should continue to process requests. 2673: # Side-effects: 2674: # The default domain/system context is modified for this daemon. 2675: # a reply is sent to the client. 2676: # 2677: sub SelectHostHandler { 2678: my $cmd = shift; 2679: my $tail = shift; 2680: my $socket = shift; 2681: 2682: my $userinput ="$cmd:$tail"; 2683: 2684: Reply($client, &sethost($userinput)."\n", $userinput); 2685: 2686: 2687: return 1; 2688: } 2689: RegisterHandler("sethost", \&SelectHostHandler, 0, 1, 0); 2690: 2691: # Process a request to exit: 2692: # - "bye" is sent to the client. 2693: # - The client socket is shutdown and closed. 2694: # - We indicate to the caller that we should exit. 2695: # Formal Parameters: 2696: # $cmd - The command that got us here. 2697: # $tail - Tail of the command (empty). 2698: # $client - Socket open on the tail. 2699: # Returns: 2700: # 0 - Indicating the program should exit!! 2701: # 2702: sub ExitHandler { 2703: my $cmd = shift; 2704: my $tail = shift; 2705: my $client = shift; 2706: 2707: my $userinput = "$cmd:$tail"; 2708: 2709: &logthis("Client $clientip ($clientname) hanging up: $userinput"); 2710: Reply($client, "bye\n", $userinput); 2711: $client->shutdown(2); # shutdown the socket forcibly. 2712: $client->close(); 2713: 2714: return 0; 2715: } 2716: RegisterHandler("exit", \&ExitHandler, 0, 1,1); 2717: RegisterHandler("init", \&ExitHandler, 0, 1,1); # RE-init is like exit. 2718: RegisterHandler("quit", \&ExitHandler, 0, 1,1); # I like this too! 2719: #------------------------------------------------------------------------------------ 2720: # 2721: # Process a Request. Takes a request from the client validates 2722: # it and performs the operation requested by it. Returns 2723: # a response to the client. 2724: # 2725: # Parameters: 2726: # request - A string containing the user's request. 2727: # Returns: 2728: # 0 - Requested to exit, caller should shut down. 2729: # 1 - Accept additional requests from the client. 2730: # 2731: sub ProcessRequest { 2732: my $Request = shift; 2733: my $KeepGoing = 1; # Assume we're not asked to stop. 2734: 2735: my $wasenc=0; 2736: my $userinput = $Request; # for compatibility with oldcode <yeach> 2737: 2738: 2739: # ------------------------------------------------------------ See if encrypted 2740: 2741: if($userinput =~ /^enc/) { 2742: $wasenc = 1; 2743: $userinput = Decipher($userinput); 2744: if(! $userinput) { 2745: Failure($client,"error:Encrypted data without negotiating key"); 2746: return 0; # Break off with this imposter. 2747: } 2748: } 2749: # Split off the request keyword from the rest of the stuff. 2750: 2751: my ($command, $tail) = split(/:/, $userinput, 2); 2752: 2753: Debug("Command received: $command, encoded = $wasenc"); 2754: 2755: 2756: # ------------------------------------------------------------- Normal commands 2757: 2758: # 2759: # If the command is in the hash, then execute it via the hash dispatch: 2760: # 2761: if(defined $Dispatcher{$command}) { 2762: 2763: my $DispatchInfo = $Dispatcher{$command}; 2764: my $Handler = $$DispatchInfo[0]; 2765: my $NeedEncode = $$DispatchInfo[1]; 2766: my $ClientTypes = $$DispatchInfo[2]; 2767: Debug("Matched dispatch hash: mustencode: $NeedEncode ClientType $ClientTypes"); 2768: 2769: # Validate the request: 2770: 2771: my $ok = 1; 2772: my $requesterprivs = 0; 2773: if(isClient()) { 2774: $requesterprivs |= $CLIENT_OK; 2775: } 2776: if(isManager()) { 2777: $requesterprivs |= $MANAGER_OK; 2778: } 2779: if($NeedEncode && (!$wasenc)) { 2780: Debug("Must encode but wasn't: $NeedEncode $wasenc"); 2781: $ok = 0; 2782: } 2783: if(($ClientTypes & $requesterprivs) == 0) { 2784: Debug("Client not privileged to do this operation"); 2785: $ok = 0; 2786: } 2787: 2788: if($ok) { 2789: Debug("Dispatching to handler $command $tail"); 2790: $KeepGoing = &$Handler($command, $tail, $client); 2791: } else { 2792: Debug("Refusing to dispatch because ok is false"); 2793: Failure($client, "refused", $userinput); 2794: } 2795: 2796: 2797: # ------------------------------------------------------------- unknown command 2798: 2799: } else { 2800: # unknown command 2801: Failure($client, "unknown_cmd\n", $userinput); 2802: } 2803: 2804: return $KeepGoing; 2805: } 2806: 2807: 2808: # 2809: # GetCertificate: Given a transaction that requires a certificate, 2810: # this function will extract the certificate from the transaction 2811: # request. Note that at this point, the only concept of a certificate 2812: # is the hostname to which we are connected. 2813: # 2814: # Parameter: 2815: # request - The request sent by our client (this parameterization may 2816: # need to change when we really use a certificate granting 2817: # authority. 2818: # 2819: sub GetCertificate { 2820: my $request = shift; 2821: 2822: return $clientip; 2823: } 2824: 2825: 2826: 2827: # 2828: # ReadManagerTable: Reads in the current manager table. For now this is 2829: # done on each manager authentication because: 2830: # - These authentications are not frequent 2831: # - This allows dynamic changes to the manager table 2832: # without the need to signal to the lond. 2833: # 2834: 2835: sub ReadManagerTable { 2836: 2837: # Clean out the old table first.. 2838: 2839: foreach my $key (keys %managers) { 2840: delete $managers{$key}; 2841: } 2842: 2843: my $tablename = $perlvar{'lonTabDir'}."/managers.tab"; 2844: if (!open (MANAGERS, $tablename)) { 2845: logthis('No manager table. Nobody can manage!!'); 2846: return; 2847: } 2848: while(my $host = <MANAGERS>) { 2849: chomp($host); 2850: if ($host =~ "^#") { # Comment line. 2851: logthis(' Skipping line: '. "$host\n"); 2852: next; 2853: } 2854: if (!defined $hostip{$host}) { # This is a non cluster member 2855: # The entry is of the form: 2856: # cluname:hostname 2857: # cluname - A 'cluster hostname' is needed in order to negotiate 2858: # the host key. 2859: # hostname- The dns name of the host. 2860: # 2861: my($cluname, $dnsname) = split(/:/, $host); 2862: 2863: my $ip = gethostbyname($dnsname); 2864: if(defined($ip)) { # bad names don't deserve entry. 2865: my $hostip = inet_ntoa($ip); 2866: $managers{$hostip} = $cluname; 2867: logthis(' registering manager '. 2868: "$dnsname as $cluname with $hostip \n"); 2869: } 2870: } else { 2871: logthis(' existing host'." $host\n"); 2872: $managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber 2873: } 2874: } 2875: } 2876: 2877: # 2878: # ValidManager: Determines if a given certificate represents a valid manager. 2879: # in this primitive implementation, the 'certificate' is 2880: # just the connecting loncapa client name. This is checked 2881: # against a valid client list in the configuration. 2882: # 2883: # 2884: sub ValidManager { 2885: my $certificate = shift; 2886: 2887: return isManager; 2888: } 2889: # 2890: # CopyFile: Called as part of the process of installing a 2891: # new configuration file. This function copies an existing 2892: # file to a backup file. 2893: # Parameters: 2894: # oldfile - Name of the file to backup. 2895: # newfile - Name of the backup file. 2896: # Return: 2897: # 0 - Failure (errno has failure reason). 2898: # 1 - Success. 2899: # 2900: sub CopyFile { 2901: my $oldfile = shift; 2902: my $newfile = shift; 2903: 2904: # The file must exist: 2905: 2906: if(-e $oldfile) { 2907: 2908: # Read the old file. 2909: 2910: my $oldfh = IO::File->new("< $oldfile"); 2911: if(!$oldfh) { 2912: return 0; 2913: } 2914: my @contents = <$oldfh>; # Suck in the entire file. 2915: 2916: # write the backup file: 2917: 2918: my $newfh = IO::File->new("> $newfile"); 2919: if(!(defined $newfh)){ 2920: return 0; 2921: } 2922: my $lines = scalar @contents; 2923: for (my $i =0; $i < $lines; $i++) { 2924: print $newfh ($contents[$i]); 2925: } 2926: 2927: $oldfh->close; 2928: $newfh->close; 2929: 2930: chmod(0660, $newfile); 2931: 2932: return 1; 2933: 2934: } else { 2935: return 0; 2936: } 2937: } 2938: # 2939: # Host files are passed out with externally visible host IPs. 2940: # If, for example, we are behind a fire-wall or NAT host, our 2941: # internally visible IP may be different than the externally 2942: # visible IP. Therefore, we always adjust the contents of the 2943: # host file so that the entry for ME is the IP that we believe 2944: # we have. At present, this is defined as the entry that 2945: # DNS has for us. If by some chance we are not able to get a 2946: # DNS translation for us, then we assume that the host.tab file 2947: # is correct. 2948: # BUGBUGBUG - in the future, we really should see if we can 2949: # easily query the interface(s) instead. 2950: # Parameter(s): 2951: # contents - The contents of the host.tab to check. 2952: # Returns: 2953: # newcontents - The adjusted contents. 2954: # 2955: # 2956: sub AdjustHostContents { 2957: my $contents = shift; 2958: my $adjusted; 2959: my $me = $perlvar{'lonHostID'}; 2960: 2961: foreach my $line (split(/\n/,$contents)) { 2962: if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { 2963: chomp($line); 2964: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); 2965: if ($id eq $me) { 2966: my $ip = gethostbyname($name); 2967: my $ipnew = inet_ntoa($ip); 2968: $ip = $ipnew; 2969: # Reconstruct the host line and append to adjusted: 2970: 2971: my $newline = "$id:$domain:$role:$name:$ip"; 2972: if($maxcon ne "") { # Not all hosts have loncnew tuning params 2973: $newline .= ":$maxcon:$idleto:$mincon"; 2974: } 2975: $adjusted .= $newline."\n"; 2976: 2977: } else { # Not me, pass unmodified. 2978: $adjusted .= $line."\n"; 2979: } 2980: } else { # Blank or comment never re-written. 2981: $adjusted .= $line."\n"; # Pass blanks and comments as is. 2982: } 2983: } 2984: return $adjusted; 2985: } 2986: # 2987: # InstallFile: Called to install an administrative file: 2988: # - The file is created with <name>.tmp 2989: # - The <name>.tmp file is then mv'd to <name> 2990: # This lugubrious procedure is done to ensure that we are never without 2991: # a valid, even if dated, version of the file regardless of who crashes 2992: # and when the crash occurs. 2993: # 2994: # Parameters: 2995: # Name of the file 2996: # File Contents. 2997: # Return: 2998: # nonzero - success. 2999: # 0 - failure and $! has an errno. 3000: # 3001: sub InstallFile { 3002: my $Filename = shift; 3003: my $Contents = shift; 3004: my $TempFile = $Filename.".tmp"; 3005: 3006: # Open the file for write: 3007: 3008: my $fh = IO::File->new("> $TempFile"); # Write to temp. 3009: if(!(defined $fh)) { 3010: &logthis(' Unable to create '.$TempFile.""); 3011: return 0; 3012: } 3013: # write the contents of the file: 3014: 3015: print $fh ($Contents); 3016: $fh->close; # In case we ever have a filesystem w. locking 3017: 3018: chmod(0660, $TempFile); 3019: 3020: # Now we can move install the file in position. 3021: 3022: move($TempFile, $Filename); 3023: 3024: return 1; 3025: } 3026: # 3027: # ConfigFileFromSelector: converts a configuration file selector 3028: # (one of host or domain at this point) into a 3029: # configuration file pathname. 3030: # 3031: # Parameters: 3032: # selector - Configuration file selector. 3033: # Returns: 3034: # Full path to the file or undef if the selector is invalid. 3035: # 3036: sub ConfigFileFromSelector { 3037: my $selector = shift; 3038: my $tablefile; 3039: 3040: my $tabledir = $perlvar{'lonTabDir'}.'/'; 3041: if ($selector eq "hosts") { 3042: $tablefile = $tabledir."hosts.tab"; 3043: } elsif ($selector eq "domain") { 3044: $tablefile = $tabledir."domain.tab"; 3045: } else { 3046: return undef; 3047: } 3048: return $tablefile; 3049: 3050: } 3051: # 3052: # PushFile: Called to do an administrative push of a file. 3053: # - Ensure the file being pushed is one we support. 3054: # - Backup the old file to <filename.saved> 3055: # - Separate the contents of the new file out from the 3056: # rest of the request. 3057: # - Write the new file. 3058: # Parameter: 3059: # Request - The entire user request. This consists of a : separated 3060: # string pushfile:tablename:contents. 3061: # NOTE: The contents may have :'s in it as well making things a bit 3062: # more interesting... but not much. 3063: # Returns: 3064: # String to send to client ("ok" or "refused" if bad file). 3065: # 3066: sub PushFile { 3067: my $request = shift; 3068: my ($command, $filename, $contents) = split(":", $request, 3); 3069: 3070: # At this point in time, pushes for only the following tables are 3071: # supported: 3072: # hosts.tab ($filename eq host). 3073: # domain.tab ($filename eq domain). 3074: # Construct the destination filename or reject the request. 3075: # 3076: # lonManage is supposed to ensure this, however this session could be 3077: # part of some elaborate spoof that managed somehow to authenticate. 3078: # 3079: 3080: 3081: my $tablefile = ConfigFileFromSelector($filename); 3082: if(! (defined $tablefile)) { 3083: return "refused"; 3084: } 3085: # 3086: # >copy< the old table to the backup table 3087: # don't rename in case system crashes/reboots etc. in the time 3088: # window between a rename and write. 3089: # 3090: my $backupfile = $tablefile; 3091: $backupfile =~ s/\.tab$/.old/; 3092: if(!CopyFile($tablefile, $backupfile)) { 3093: &logthis(' CopyFile from '.$tablefile." to ".$backupfile." failed "); 3094: return "error:$!"; 3095: } 3096: &logthis(' Pushfile: backed up ' 3097: .$tablefile." to $backupfile"); 3098: 3099: # If the file being pushed is the host file, we adjust the entry for ourself so that the 3100: # IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible 3101: # to conceive of conditions where we don't have a DNS entry locally. This is possible in a 3102: # network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now) 3103: # that possibilty. 3104: 3105: if($filename eq "host") { 3106: $contents = AdjustHostContents($contents); 3107: } 3108: 3109: # Install the new file: 3110: 3111: if(!InstallFile($tablefile, $contents)) { 3112: &logthis(' Pushfile: unable to install ' 3113: .$tablefile." $! "); 3114: return "error:$!"; 3115: } else { 3116: &logthis(' Installed new '.$tablefile 3117: .""); 3118: 3119: } 3120: 3121: 3122: # Indicate success: 3123: 3124: return "ok"; 3125: 3126: } 3127: 3128: # 3129: # Called to re-init either lonc or lond. 3130: # 3131: # Parameters: 3132: # request - The full request by the client. This is of the form 3133: # reinit:<process> 3134: # where <process> is allowed to be either of 3135: # lonc or lond 3136: # 3137: # Returns: 3138: # The string to be sent back to the client either: 3139: # ok - Everything worked just fine. 3140: # error:why - There was a failure and why describes the reason. 3141: # 3142: # 3143: sub ReinitProcess { 3144: my $request = shift; 3145: 3146: 3147: # separate the request (reinit) from the process identifier and 3148: # validate it producing the name of the .pid file for the process. 3149: # 3150: # 3151: my ($junk, $process) = split(":", $request); 3152: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/'; 3153: if($process eq 'lonc') { 3154: $processpidfile = $processpidfile."lonc.pid"; 3155: if (!open(PIDFILE, "< $processpidfile")) { 3156: return "error:Open failed for $processpidfile"; 3157: } 3158: my $loncpid = <PIDFILE>; 3159: close(PIDFILE); 3160: logthis(' Reinitializing lonc pid='.$loncpid 3161: .""); 3162: kill("USR2", $loncpid); 3163: } elsif ($process eq 'lond') { 3164: logthis(' Reinitializing self (lond) '); 3165: &UpdateHosts; # Lond is us!! 3166: } else { 3167: &logthis('"); 3169: return "error:Invalid process identifier $process"; 3170: } 3171: return 'ok'; 3172: } 3173: # Validate a line in a configuration file edit script: 3174: # Validation includes: 3175: # - Ensuring the command is valid. 3176: # - Ensuring the command has sufficient parameters 3177: # Parameters: 3178: # scriptline - A line to validate (\n has been stripped for what it's worth). 3179: # 3180: # Return: 3181: # 0 - Invalid scriptline. 3182: # 1 - Valid scriptline 3183: # NOTE: 3184: # Only the command syntax is checked, not the executability of the 3185: # command. 3186: # 3187: sub isValidEditCommand { 3188: my $scriptline = shift; 3189: 3190: # Line elements are pipe separated: 3191: 3192: my ($command, $key, $newline) = split(/\|/, $scriptline); 3193: &logthis(' isValideditCommand checking: '. 3194: "Command = '$command', Key = '$key', Newline = '$newline' \n"); 3195: 3196: if ($command eq "delete") { 3197: # 3198: # key with no newline. 3199: # 3200: if( ($key eq "") || ($newline ne "")) { 3201: return 0; # Must have key but no newline. 3202: } else { 3203: return 1; # Valid syntax. 3204: } 3205: } elsif ($command eq "replace") { 3206: # 3207: # key and newline: 3208: # 3209: if (($key eq "") || ($newline eq "")) { 3210: return 0; 3211: } else { 3212: return 1; 3213: } 3214: } elsif ($command eq "append") { 3215: if (($key ne "") && ($newline eq "")) { 3216: return 1; 3217: } else { 3218: return 0; 3219: } 3220: } else { 3221: return 0; # Invalid command. 3222: } 3223: return 0; # Should not get here!!! 3224: } 3225: # 3226: # ApplyEdit - Applies an edit command to a line in a configuration 3227: # file. It is the caller's responsiblity to validate the 3228: # edit line. 3229: # Parameters: 3230: # $directive - A single edit directive to apply. 3231: # Edit directives are of the form: 3232: # append|newline - Appends a new line to the file. 3233: # replace|key|newline - Replaces the line with key value 'key' 3234: # delete|key - Deletes the line with key value 'key'. 3235: # $editor - A config file editor object that contains the 3236: # file being edited. 3237: # 3238: sub ApplyEdit { 3239: my $directive = shift; 3240: my $editor = shift; 3241: 3242: # Break the directive down into its command and its parameters 3243: # (at most two at this point. The meaning of the parameters, if in fact 3244: # they exist depends on the command). 3245: 3246: my ($command, $p1, $p2) = split(/\|/, $directive); 3247: 3248: if($command eq "append") { 3249: $editor->Append($p1); # p1 - key p2 null. 3250: } elsif ($command eq "replace") { 3251: $editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline. 3252: } elsif ($command eq "delete") { 3253: $editor->DeleteLine($p1); # p1 - key p2 null. 3254: } else { # Should not get here!!! 3255: die "Invalid command given to ApplyEdit $command"; 3256: } 3257: } 3258: # 3259: # AdjustOurHost: 3260: # Adjusts a host file stored in a configuration file editor object 3261: # for the true IP address of this host. This is necessary for hosts 3262: # that live behind a firewall. 3263: # Those hosts have a publicly distributed IP of the firewall, but 3264: # internally must use their actual IP. We assume that a given 3265: # host only has a single IP interface for now. 3266: # Formal Parameters: 3267: # editor - The configuration file editor to adjust. This 3268: # editor is assumed to contain a hosts.tab file. 3269: # Strategy: 3270: # - Figure out our hostname. 3271: # - Lookup the entry for this host. 3272: # - Modify the line to contain our IP 3273: # - Do a replace for this host. 3274: sub AdjustOurHost { 3275: my $editor = shift; 3276: 3277: # figure out who I am. 3278: 3279: my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname. 3280: 3281: # Get my host file entry. 3282: 3283: my $ConfigLine = $editor->Find($myHostName); 3284: if(! (defined $ConfigLine)) { 3285: die "AdjustOurHost - no entry for me in hosts file $myHostName"; 3286: } 3287: # figure out my IP: 3288: # Use the config line to get my hostname. 3289: # Use gethostbyname to translate that into an IP address. 3290: # 3291: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine); 3292: my $BinaryIp = gethostbyname($name); 3293: my $ip = inet_ntoa($ip); 3294: # 3295: # Reassemble the config line from the elements in the list. 3296: # Note that if the loncnew items were not present before, they will 3297: # be now even if they would be empty 3298: # 3299: my $newConfigLine = $id; 3300: foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) { 3301: $newConfigLine .= ":".$item; 3302: } 3303: # Replace the line: 3304: 3305: $editor->ReplaceLine($id, $newConfigLine); 3306: 3307: } 3308: # 3309: # ReplaceConfigFile: 3310: # Replaces a configuration file with the contents of a 3311: # configuration file editor object. 3312: # This is done by: 3313: # - Copying the target file to <filename>.old 3314: # - Writing the new file to <filename>.tmp 3315: # - Moving <filename.tmp> -> <filename> 3316: # This laborious process ensures that the system is never without 3317: # a configuration file that's at least valid (even if the contents 3318: # may be dated). 3319: # Parameters: 3320: # filename - Name of the file to modify... this is a full path. 3321: # editor - Editor containing the file. 3322: # 3323: sub ReplaceConfigFile { 3324: my $filename = shift; 3325: my $editor = shift; 3326: 3327: CopyFile ($filename, $filename.".old"); 3328: 3329: my $contents = $editor->Get(); # Get the contents of the file. 3330: 3331: InstallFile($filename, $contents); 3332: } 3333: # 3334: # 3335: # Called to edit a configuration table file 3336: # Parameters: 3337: # request - The entire command/request sent by lonc or lonManage 3338: # Return: 3339: # The reply to send to the client. 3340: # 3341: sub EditFile { 3342: my $request = shift; 3343: 3344: # Split the command into it's pieces: edit:filetype:script 3345: 3346: my ($request, $filetype, $script) = split(/:/, $request,3); # : in script 3347: 3348: # Check the pre-coditions for success: 3349: 3350: if($request != "edit") { # Something is amiss afoot alack. 3351: return "error:edit request detected, but request != 'edit'\n"; 3352: } 3353: if( ($filetype ne "hosts") && 3354: ($filetype ne "domain")) { 3355: return "error:edit requested with invalid file specifier: $filetype \n"; 3356: } 3357: 3358: # Split the edit script and check it's validity. 3359: 3360: my @scriptlines = split(/\n/, $script); # one line per element. 3361: my $linecount = scalar(@scriptlines); 3362: for(my $i = 0; $i < $linecount; $i++) { 3363: chomp($scriptlines[$i]); 3364: if(!isValidEditCommand($scriptlines[$i])) { 3365: return "error:edit with bad script line: '$scriptlines[$i]' \n"; 3366: } 3367: } 3368: 3369: # Execute the edit operation. 3370: # - Create a config file editor for the appropriate file and 3371: # - execute each command in the script: 3372: # 3373: my $configfile = ConfigFileFromSelector($filetype); 3374: if (!(defined $configfile)) { 3375: return "refused\n"; 3376: } 3377: my $editor = ConfigFileEdit->new($configfile); 3378: 3379: for (my $i = 0; $i < $linecount; $i++) { 3380: ApplyEdit($scriptlines[$i], $editor); 3381: } 3382: # If the file is the host file, ensure that our host is 3383: # adjusted to have our ip: 3384: # 3385: if($filetype eq "host") { 3386: AdjustOurHost($editor); 3387: } 3388: # Finally replace the current file with our file. 3389: # 3390: ReplaceConfigFile($configfile, $editor); 3391: 3392: return "ok\n"; 3393: } 3394: # 3395: # Convert an error return code from lcpasswd to a string value. 3396: # 3397: sub lcpasswdstrerror { 3398: my $ErrorCode = shift; 3399: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { 3400: return "lcpasswd Unrecognized error return value ".$ErrorCode; 3401: } else { 3402: return $passwderrors[$ErrorCode]; 3403: } 3404: } 3405: 3406: # 3407: # Convert an error return code from lcuseradd to a string value: 3408: # 3409: sub lcuseraddstrerror { 3410: my $ErrorCode = shift; 3411: if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) { 3412: return "lcuseradd - Unrecognized error code: ".$ErrorCode; 3413: } else { 3414: return $adderrors[$ErrorCode]; 3415: } 3416: } 3417: 3418: # grabs exception and records it to log before exiting 3419: sub catchexception { 3420: my ($error)=@_; 3421: $SIG{'QUIT'}='DEFAULT'; 3422: $SIG{__DIE__}='DEFAULT'; 3423: &status("Catching exception"); 3424: &logthis("CRITICAL: " 3425: ."ABNORMAL EXIT. Child $$ for server $thisserver died through " 3426: ."a crash with this error msg->[$error]"); 3427: &logthis('Famous last words: '.$status.' - '.$lastlog); 3428: if ($client) { print $client "error: $error\n"; } 3429: $server->close(); 3430: die($error); 3431: } 3432: 3433: sub timeout { 3434: &status("Handling Timeout"); 3435: &logthis("CRITICAL: TIME OUT ".$$.""); 3436: &catchexception('Timeout'); 3437: } 3438: # -------------------------------- Set signal handlers to record abnormal exits 3439: 3440: $SIG{'QUIT'}=\&catchexception; 3441: $SIG{__DIE__}=\&catchexception; 3442: 3443: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf 3444: &status("Read loncapa.conf and loncapa_apache.conf"); 3445: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); 3446: %perlvar=%{$perlvarref}; 3447: undef $perlvarref; 3448: 3449: # ----------------------------- Make sure this process is running from user=www 3450: my $wwwid=getpwnam('www'); 3451: if ($wwwid!=$<) { 3452: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 3453: my $subj="LON: $currenthostid User ID mismatch"; 3454: system("echo 'User ID mismatch. lond must be run as user www.' |\ 3455: mailto $emailto -s '$subj' > /dev/null"); 3456: exit 1; 3457: } 3458: 3459: # --------------------------------------------- Check if other instance running 3460: 3461: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; 3462: 3463: if (-e $pidfile) { 3464: my $lfh=IO::File->new("$pidfile"); 3465: my $pide=<$lfh>; 3466: chomp($pide); 3467: if (kill 0 => $pide) { die "already running"; } 3468: } 3469: 3470: # ------------------------------------------------------------- Read hosts file 3471: 3472: 3473: 3474: # establish SERVER socket, bind and listen. 3475: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'}, 3476: Type => SOCK_STREAM, 3477: Proto => 'tcp', 3478: Reuse => 1, 3479: Listen => 10 ) 3480: or die "making socket: $@\n"; 3481: 3482: # --------------------------------------------------------- Do global variables 3483: 3484: # global variables 3485: 3486: my %children = (); # keys are current child process IDs 3487: my $children = 0; # current number of children 3488: 3489: sub REAPER { # takes care of dead children 3490: $SIG{CHLD} = \&REAPER; 3491: &status("Handling child death"); 3492: my $pid = wait; 3493: if (defined($children{$pid})) { 3494: &logthis("Child $pid died"); 3495: $children --; 3496: delete $children{$pid}; 3497: } else { 3498: &logthis("Unknown Child $pid died"); 3499: } 3500: &status("Finished Handling child death"); 3501: } 3502: 3503: sub HUNTSMAN { # signal handler for SIGINT 3504: &status("Killing children (INT)"); 3505: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 3506: kill 'INT' => keys %children; 3507: &logthis("Free socket: ".shutdown($server,2)); # free up socket 3508: my $execdir=$perlvar{'lonDaemons'}; 3509: unlink("$execdir/logs/lond.pid"); 3510: &logthis("CRITICAL: Shutting down"); 3511: &status("Done killing children"); 3512: exit; # clean up with dignity 3513: } 3514: 3515: sub HUPSMAN { # signal handler for SIGHUP 3516: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 3517: &status("Killing children for restart (HUP)"); 3518: kill 'INT' => keys %children; 3519: &logthis("Free socket: ".shutdown($server,2)); # free up socket 3520: &logthis("CRITICAL: Restarting"); 3521: my $execdir=$perlvar{'lonDaemons'}; 3522: unlink("$execdir/logs/lond.pid"); 3523: &status("Restarting self (HUP)"); 3524: exec("$execdir/lond"); # here we go again 3525: } 3526: 3527: # 3528: # Kill off hashes that describe the host table prior to re-reading it. 3529: # Hashes affected are: 3530: # %hostid, %hostdom %hostip 3531: # 3532: sub KillHostHashes { 3533: foreach my $key (keys %hostid) { 3534: delete $hostid{$key}; 3535: } 3536: foreach my $key (keys %hostdom) { 3537: delete $hostdom{$key}; 3538: } 3539: foreach my $key (keys %hostip) { 3540: delete $hostip{$key}; 3541: } 3542: } 3543: # 3544: # Read in the host table from file and distribute it into the various hashes: 3545: # 3546: # - %hostid - Indexed by IP, the loncapa hostname. 3547: # - %hostdom - Indexed by loncapa hostname, the domain. 3548: # - %hostip - Indexed by hostid, the Ip address of the host. 3549: sub ReadHostTable { 3550: 3551: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; 3552: 3553: while (my $configline=<CONFIG>) { 3554: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); 3555: chomp($ip); $ip=~s/\D+$//; 3556: $hostid{$ip}=$id; 3557: $hostdom{$id}=$domain; 3558: $hostip{$id}=$ip; 3559: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } 3560: } 3561: close(CONFIG); 3562: } 3563: # 3564: # Reload the Apache daemon's state. 3565: # This is done by invoking /home/httpd/perl/apachereload 3566: # a setuid perl script that can be root for us to do this job. 3567: # 3568: sub ReloadApache { 3569: my $execdir = $perlvar{'lonDaemons'}; 3570: my $script = $execdir."/apachereload"; 3571: system($script); 3572: } 3573: 3574: # 3575: # Called in response to a USR2 signal. 3576: # - Reread hosts.tab 3577: # - All children connected to hosts that were removed from hosts.tab 3578: # are killed via SIGINT 3579: # - All children connected to previously existing hosts are sent SIGUSR1 3580: # - Our internal hosts hash is updated to reflect the new contents of 3581: # hosts.tab causing connections from hosts added to hosts.tab to 3582: # now be honored. 3583: # 3584: sub UpdateHosts { 3585: &status("Reload hosts.tab"); 3586: logthis(' Updating connections '); 3587: # 3588: # The %children hash has the set of IP's we currently have children 3589: # on. These need to be matched against records in the hosts.tab 3590: # Any ip's no longer in the table get killed off they correspond to 3591: # either dropped or changed hosts. Note that the re-read of the table 3592: # will take care of new and changed hosts as connections come into being. 3593: 3594: 3595: KillHostHashes; 3596: ReadHostTable; 3597: 3598: foreach my $child (keys %children) { 3599: my $childip = $children{$child}; 3600: if(!$hostid{$childip}) { 3601: logthis(' UpdateHosts killing child ' 3602: ." $child for ip $childip "); 3603: kill('INT', $child); 3604: } else { 3605: logthis(' keeping child for ip ' 3606: ." $childip (pid=$child) "); 3607: } 3608: } 3609: ReloadApache; 3610: &status("Finished reloading hosts.tab"); 3611: } 3612: 3613: 3614: sub checkchildren { 3615: &status("Checking on the children (sending signals)"); 3616: &initnewstatus(); 3617: &logstatus(); 3618: &logthis('Going to check on the children'); 3619: my $docdir=$perlvar{'lonDocRoot'}; 3620: foreach (sort keys %children) { 3621: sleep 1; 3622: unless (kill 'USR1' => $_) { 3623: &logthis ('Child '.$_.' is dead'); 3624: &logstatus($$.' is dead'); 3625: } 3626: } 3627: sleep 5; 3628: $SIG{ALRM} = sub { die "timeout" }; 3629: $SIG{__DIE__} = 'DEFAULT'; 3630: &status("Checking on the children (waiting for reports)"); 3631: foreach (sort keys %children) { 3632: unless (-e "$docdir/lon-status/londchld/$_.txt") { 3633: eval { 3634: alarm(300); 3635: &logthis('Child '.$_.' did not respond'); 3636: kill 9 => $_; 3637: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 3638: #$subj="LON: $currenthostid killed lond process $_"; 3639: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; 3640: #$execdir=$perlvar{'lonDaemons'}; 3641: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; 3642: alarm(0); 3643: } 3644: } 3645: } 3646: $SIG{ALRM} = 'DEFAULT'; 3647: $SIG{__DIE__} = \&catchexception; 3648: &status("Finished checking children"); 3649: } 3650: 3651: # --------------------------------------------------------------------- Logging 3652: 3653: sub logthis { 3654: my $message=shift; 3655: my $execdir=$perlvar{'lonDaemons'}; 3656: my $fh=IO::File->new(">>$execdir/logs/lond.log"); 3657: my $now=time; 3658: my $local=localtime($now); 3659: $lastlog=$local.': '.$message; 3660: print $fh "$local ($$): $message\n"; 3661: } 3662: 3663: # ------------------------- Conditional log if $DEBUG true. 3664: sub Debug { 3665: my $message = shift; 3666: if($DEBUG) { 3667: &logthis($message); 3668: } 3669: } 3670: 3671: # 3672: # Sub to do replies to client.. this gives a hook for some 3673: # debug tracing too: 3674: # Parameters: 3675: # fd - File open on client. 3676: # reply - Text to send to client. 3677: # request - Original request from client. 3678: # 3679: # Note: This increments Transactions 3680: # 3681: sub Reply { 3682: alarm(120); 3683: my $fd = shift; 3684: my $reply = shift; 3685: my $request = shift; 3686: 3687: print $fd $reply; 3688: Debug("Request was $request Reply was $reply"); 3689: 3690: $Transactions++; 3691: alarm(0); 3692: 3693: 3694: } 3695: # 3696: # Sub to report a failure. 3697: # This function: 3698: # - Increments the failure statistic counters. 3699: # - Invokes Reply to send the error message to the client. 3700: # Parameters: 3701: # fd - File descriptor open on the client 3702: # reply - Reply text to emit. 3703: # request - The original request message (used by Reply 3704: # to debug if that's enabled. 3705: # Implicit outputs: 3706: # $Failures- The number of failures is incremented. 3707: # Reply (invoked here) sends a message to the 3708: # client: 3709: # 3710: sub Failure { 3711: my $fd = shift; 3712: my $reply = shift; 3713: my $request = shift; 3714: 3715: $Failures++; 3716: Reply($fd, $reply, $request); # That's simple eh? 3717: } 3718: # ------------------------------------------------------------------ Log status 3719: 3720: sub logstatus { 3721: &status("Doing logging"); 3722: my $docdir=$perlvar{'lonDocRoot'}; 3723: { 3724: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); 3725: print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; 3726: $fh->close(); 3727: } 3728: &status("Finished londstatus.txt"); 3729: { 3730: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); 3731: print $fh $status."\n".$lastlog."\n".time; 3732: $fh->close(); 3733: } 3734: ResetStatistics; 3735: &status("Finished logging"); 3736: 3737: } 3738: 3739: sub initnewstatus { 3740: my $docdir=$perlvar{'lonDocRoot'}; 3741: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); 3742: my $now=time; 3743: my $local=localtime($now); 3744: print $fh "LOND status $local - parent $$\n\n"; 3745: opendir(DIR,"$docdir/lon-status/londchld"); 3746: while (my $filename=readdir(DIR)) { 3747: unlink("$docdir/lon-status/londchld/$filename"); 3748: } 3749: closedir(DIR); 3750: } 3751: 3752: # -------------------------------------------------------------- Status setting 3753: 3754: sub status { 3755: my $what=shift; 3756: my $now=time; 3757: my $local=localtime($now); 3758: my $status = "lond: $what $local "; 3759: if($Transactions) { 3760: $status .= " Transactions: $Transactions Failed; $Failures"; 3761: } 3762: $0=$status; 3763: } 3764: 3765: # -------------------------------------------------------- Escape Special Chars 3766: 3767: sub escape { 3768: my $str=shift; 3769: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 3770: return $str; 3771: } 3772: 3773: # ----------------------------------------------------- Un-Escape Special Chars 3774: 3775: sub unescape { 3776: my $str=shift; 3777: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 3778: return $str; 3779: } 3780: 3781: # ----------------------------------------------------------- Send USR1 to lonc 3782: 3783: sub reconlonc { 3784: my $peerfile=shift; 3785: &logthis("Trying to reconnect for $peerfile"); 3786: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 3787: if (my $fh=IO::File->new("$loncfile")) { 3788: my $loncpid=<$fh>; 3789: chomp($loncpid); 3790: if (kill 0 => $loncpid) { 3791: &logthis("lonc at pid $loncpid responding, sending USR1"); 3792: kill USR1 => $loncpid; 3793: } else { 3794: &logthis("CRITICAL: " 3795: ."lonc at pid $loncpid not responding, giving up"); 3796: } 3797: } else { 3798: &logthis('CRITICAL: lonc not running, giving up'); 3799: } 3800: } 3801: 3802: # -------------------------------------------------- Non-critical communication 3803: 3804: sub subreply { 3805: my ($cmd,$server)=@_; 3806: my $peerfile="$perlvar{'lonSockDir'}/$server"; 3807: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 3808: Type => SOCK_STREAM, 3809: Timeout => 10) 3810: or return "con_lost"; 3811: print $sclient "$cmd\n"; 3812: my $answer=<$sclient>; 3813: chomp($answer); 3814: if (!$answer) { $answer="con_lost"; } 3815: return $answer; 3816: } 3817: 3818: sub reply { 3819: my ($cmd,$server)=@_; 3820: my $answer; 3821: if ($server ne $currenthostid) { 3822: $answer=subreply($cmd,$server); 3823: if ($answer eq 'con_lost') { 3824: $answer=subreply("ping",$server); 3825: if ($answer ne $server) { 3826: &logthis("sub reply: answer != server answer is $answer, server is $server"); 3827: &reconlonc("$perlvar{'lonSockDir'}/$server"); 3828: } 3829: $answer=subreply($cmd,$server); 3830: } 3831: } else { 3832: $answer='self_reply'; 3833: } 3834: return $answer; 3835: } 3836: 3837: # -------------------------------------------------------------- Talk to lonsql 3838: 3839: sub sqlreply { 3840: my ($cmd)=@_; 3841: my $answer=subsqlreply($cmd); 3842: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); } 3843: return $answer; 3844: } 3845: 3846: sub subsqlreply { 3847: my ($cmd)=@_; 3848: my $unixsock="mysqlsock"; 3849: my $peerfile="$perlvar{'lonSockDir'}/$unixsock"; 3850: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 3851: Type => SOCK_STREAM, 3852: Timeout => 10) 3853: or return "con_lost"; 3854: print $sclient "$cmd\n"; 3855: my $answer=<$sclient>; 3856: chomp($answer); 3857: if (!$answer) { $answer="con_lost"; } 3858: return $answer; 3859: } 3860: 3861: # -------------------------------------------- Return path to profile directory 3862: 3863: sub propath { 3864: my ($udom,$uname)=@_; 3865: $udom=~s/\W//g; 3866: $uname=~s/\W//g; 3867: my $subdir=$uname.'__'; 3868: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 3869: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 3870: return $proname; 3871: } 3872: 3873: # --------------------------------------- Is this the home server of an author? 3874: 3875: sub ishome { 3876: my $author=shift; 3877: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 3878: my ($udom,$uname)=split(/\//,$author); 3879: my $proname=propath($udom,$uname); 3880: if (-e $proname) { 3881: return 'owner'; 3882: } else { 3883: return 'not_owner'; 3884: } 3885: } 3886: 3887: # ======================================================= Continue main program 3888: # ---------------------------------------------------- Fork once and dissociate 3889: 3890: my $fpid=fork; 3891: exit if $fpid; 3892: die "Couldn't fork: $!" unless defined ($fpid); 3893: 3894: POSIX::setsid() or die "Can't start new session: $!"; 3895: 3896: # ------------------------------------------------------- Write our PID on disk 3897: 3898: my $execdir=$perlvar{'lonDaemons'}; 3899: open (PIDSAVE,">$execdir/logs/lond.pid"); 3900: print PIDSAVE "$$\n"; 3901: close(PIDSAVE); 3902: &logthis("CRITICAL: ---------- Starting ----------"); 3903: &status('Starting'); 3904: 3905: 3906: 3907: # ----------------------------------------------------- Install signal handlers 3908: 3909: 3910: $SIG{CHLD} = \&REAPER; 3911: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 3912: $SIG{HUP} = \&HUPSMAN; 3913: $SIG{USR1} = \&checkchildren; 3914: $SIG{USR2} = \&UpdateHosts; 3915: 3916: # Read the host hashes: 3917: 3918: ReadHostTable; 3919: 3920: 3921: # -------------------------------------------------------------- 3922: # Accept connections. When a connection comes in, it is validated 3923: # and if good, a child process is created to process transactions 3924: # along the connection. 3925: 3926: while (1) { 3927: &status('Starting accept'); 3928: $client = $server->accept() or next; 3929: &status('Accepted '.$client.' off to spawn'); 3930: make_new_child($client); 3931: &status('Finished spawning'); 3932: } 3933: 3934: sub make_new_child { 3935: my $pid; 3936: my $sigset; 3937: 3938: $client = shift; 3939: &status('Starting new child '.$client); 3940: &logthis(' Attempting to start child ('.$client. 3941: ")"); 3942: # block signal for fork 3943: $sigset = POSIX::SigSet->new(SIGINT); 3944: sigprocmask(SIG_BLOCK, $sigset) 3945: or die "Can't block SIGINT for fork: $!\n"; 3946: 3947: die "fork: $!" unless defined ($pid = fork); 3948: 3949: $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of 3950: # connection liveness. 3951: 3952: # 3953: # Figure out who we're talking to so we can record the peer in 3954: # the pid hash. 3955: # 3956: my $caller = getpeername($client); 3957: my ($port,$iaddr)=unpack_sockaddr_in($caller); 3958: $clientip=inet_ntoa($iaddr); 3959: 3960: if ($pid) { 3961: # Parent records the child's birth and returns. 3962: sigprocmask(SIG_UNBLOCK, $sigset) 3963: or die "Can't unblock SIGINT for fork: $!\n"; 3964: $children{$pid} = $clientip; 3965: $children++; 3966: &status('Started child '.$pid); 3967: return; 3968: } else { 3969: # Child can *not* return from this subroutine. 3970: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before 3971: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns 3972: #don't get intercepted 3973: $SIG{USR1}= \&logstatus; 3974: $SIG{ALRM}= \&timeout; 3975: $lastlog='Forked '; 3976: $status='Forked'; 3977: 3978: # unblock signals 3979: sigprocmask(SIG_UNBLOCK, $sigset) 3980: or die "Can't unblock SIGINT for fork: $!\n"; 3981: 3982: 3983: 3984: &Authen::Krb5::init_context(); 3985: &Authen::Krb5::init_ets(); 3986: 3987: &status('Accepted connection'); 3988: # ============================================================================= 3989: # do something with the connection 3990: # ----------------------------------------------------------------------------- 3991: # see if we know client and check for spoof IP by challenge 3992: 3993: ReadManagerTable; # May also be a manager!! 3994: 3995: my $clientrec=($hostid{$clientip} ne undef); 3996: my $ismanager=($managers{$clientip} ne undef); 3997: $clientname = "[unknonwn]"; 3998: if($clientrec) { # Establish client type. 3999: $ConnectionType = "client"; 4000: $clientname = $hostid{$clientip}; 4001: if($ismanager) { 4002: $ConnectionType = "both"; 4003: } 4004: } else { 4005: $ConnectionType = "manager"; 4006: $clientname = $managers{$clientip}; 4007: } 4008: my $clientok; 4009: if ($clientrec || $ismanager) { 4010: &status("Waiting for init from $clientip $clientname"); 4011: &logthis('INFO: Connection, '. 4012: $clientip. 4013: " ($clientname) connection type = $ConnectionType " ); 4014: &status("Connecting $clientip ($clientname))"); 4015: my $remotereq=<$client>; 4016: $remotereq=~s/[^\w:]//g; 4017: if ($remotereq =~ /^init/) { 4018: &sethost("sethost:$perlvar{'lonHostID'}"); 4019: my $challenge="$$".time; 4020: print $client "$challenge\n"; 4021: &status("Waiting for challenge reply from $clientip ($clientname)"); 4022: $remotereq=<$client>; 4023: $remotereq=~s/\W//g; 4024: if ($challenge eq $remotereq) { 4025: $clientok=1; 4026: print $client "ok\n"; 4027: } else { 4028: &logthis("WARNING: $clientip did not reply challenge"); 4029: &status('No challenge reply '.$clientip); 4030: } 4031: } else { 4032: &logthis("WARNING: " 4033: ."$clientip failed to initialize: >$remotereq< "); 4034: &status('No init '.$clientip); 4035: } 4036: } else { 4037: &logthis("WARNING: Unknown client $clientip"); 4038: &status('Hung up on '.$clientip); 4039: } 4040: if ($clientok) { 4041: # ---------------- New known client connecting, could mean machine online again 4042: 4043: foreach my $id (keys(%hostip)) { 4044: if ($hostip{$id} ne $clientip || 4045: $hostip{$currenthostid} eq $clientip) { 4046: # no need to try to do recon's to myself 4047: next; 4048: } 4049: &reconlonc("$perlvar{'lonSockDir'}/$id"); 4050: } 4051: &logthis("Established connection: $clientname"); 4052: &status('Will listen to '.$clientname); 4053: 4054: ResetStatistics(); 4055: 4056: # ------------------------------------------------------------ Process requests 4057: my $KeepGoing = 1; 4058: while ((my $userinput=GetRequest) && $KeepGoing) { 4059: $KeepGoing = ProcessRequest($userinput); 4060: # -------------------------------------------------------------------- complete 4061: 4062: &status('Listening to '.$clientname); 4063: } 4064: # --------------------------------------------- client unknown or fishy, refuse 4065: } else { 4066: print $client "refused\n"; 4067: $client->close(); 4068: &logthis("WARNING: " 4069: ."Rejected client $clientip, closing connection"); 4070: } 4071: } 4072: 4073: # ============================================================================= 4074: 4075: &logthis("CRITICAL: " 4076: ."Disconnect from $clientip ($clientname)"); 4077: 4078: 4079: # this exit is VERY important, otherwise the child will become 4080: # a producer of more and more children, forking yourself into 4081: # process death. 4082: exit; 4083: 4084: } 4085: 4086: 4087: # 4088: # Checks to see if the input roleput request was to set 4089: # an author role. If so, invokes the lchtmldir script to set 4090: # up a correct public_html 4091: # Parameters: 4092: # request - The request sent to the rolesput subchunk. 4093: # We're looking for /domain/_au 4094: # domain - The domain in which the user is having roles doctored. 4095: # user - Name of the user for which the role is being put. 4096: # authtype - The authentication type associated with the user. 4097: # 4098: sub ManagePermissions { 4099: my $request = shift; 4100: my $domain = shift; 4101: my $user = shift; 4102: my $authtype= shift; 4103: 4104: # See if the request is of the form /$domain/_au 4105: &logthis("ruequest is $request"); 4106: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... 4107: my $execdir = $perlvar{'lonDaemons'}; 4108: my $userhome= "/home/$user" ; 4109: &logthis("system $execdir/lchtmldir $userhome $user $authtype"); 4110: system("$execdir/lchtmldir $userhome $user $authtype"); 4111: } 4112: } 4113: 4114: # 4115: # Return the full path of a user password file, whether it exists or not. 4116: # Parameters: 4117: # domain - Domain in which the password file lives. 4118: # user - name of the user. 4119: # Returns: 4120: # Full passwd path: 4121: # 4122: sub PasswordPath { 4123: my $domain = shift; 4124: my $user = shift; 4125: 4126: my $path = &propath($domain, $user); 4127: my $path .= "/passwd"; 4128: 4129: return $path; 4130: } 4131: 4132: # Password Filename 4133: # Returns the path to a passwd file given domain and user... only if 4134: # it exists. 4135: # Parameters: 4136: # domain - Domain in which to search. 4137: # user - username. 4138: # Returns: 4139: # - If the password file exists returns its path. 4140: # - If the password file does not exist, returns undefined. 4141: # 4142: sub PasswordFilename { 4143: my $domain = shift; 4144: my $user = shift; 4145: 4146: my $path = PasswordPath($domain, $user); 4147: 4148: if(-e $path) { 4149: return $path; 4150: } else { 4151: return undef; 4152: } 4153: } 4154: 4155: # 4156: # Rewrite the contents of the user's passwd file. 4157: # Parameters: 4158: # domain - domain of the user. 4159: # name - User's name. 4160: # contents - New contents of the file. 4161: # Returns: 4162: # 0 - Failed. 4163: # 1 - Success. 4164: # 4165: sub RewritePwFile { 4166: my $domain = shift; 4167: my $user = shift; 4168: my $contents = shift; 4169: 4170: my $file = PasswordFilename($domain, $user); 4171: if (defined $file) { 4172: my $pf = IO::File->new(">$file"); 4173: if($pf) { 4174: print $pf "$contents\n"; 4175: return 1; 4176: } else { 4177: return 0; 4178: } 4179: } else { 4180: return 0; 4181: } 4182: 4183: } 4184: # 4185: # GetAuthType - Determines the authorization type of a user in a domain. 4186: 4187: # Returns the authorization type or nouser if there is no such user. 4188: # 4189: sub GetAuthType { 4190: my $domain = shift; 4191: my $user = shift; 4192: 4193: Debug("GetAuthType( $domain, $user ) \n"); 4194: my $passwdfile = PasswordFilename($domain, $user); 4195: if( defined $passwdfile ) { 4196: my $pf = IO::File->new($passwdfile); 4197: my $realpassword = <$pf>; 4198: chomp($realpassword); 4199: Debug("Password info = $realpassword\n"); 4200: return $realpassword; 4201: } else { 4202: Debug("Returning nouser"); 4203: return "nouser"; 4204: } 4205: } 4206: 4207: sub addline { 4208: my ($fname,$hostid,$ip,$newline)=@_; 4209: my $contents; 4210: my $found=0; 4211: my $expr='^'.$hostid.':'.$ip.':'; 4212: $expr =~ s/\./\\\./g; 4213: my $sh; 4214: if ($sh=IO::File->new("$fname.subscription")) { 4215: while (my $subline=<$sh>) { 4216: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} 4217: } 4218: $sh->close(); 4219: } 4220: $sh=IO::File->new(">$fname.subscription"); 4221: if ($contents) { print $sh $contents; } 4222: if ($newline) { print $sh $newline; } 4223: $sh->close(); 4224: return $found; 4225: } 4226: 4227: sub getchat { 4228: my ($cdom,$cname,$udom,$uname)=@_; 4229: my %hash; 4230: my $proname=&propath($cdom,$cname); 4231: my @entries=(); 4232: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", 4233: &GDBM_READER(),0640)) { 4234: @entries=map { $_.':'.$hash{$_} } sort keys %hash; 4235: untie %hash; 4236: } 4237: my @participants=(); 4238: my $cutoff=time-60; 4239: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", 4240: &GDBM_WRCREAT(),0640)) { 4241: $hash{$uname.':'.$udom}=time; 4242: foreach (sort keys %hash) { 4243: if ($hash{$_}>$cutoff) { 4244: $participants[$#participants+1]='active_participant:'.$_; 4245: } 4246: } 4247: untie %hash; 4248: } 4249: return (@participants,@entries); 4250: } 4251: 4252: sub chatadd { 4253: my ($cdom,$cname,$newchat)=@_; 4254: my %hash; 4255: my $proname=&propath($cdom,$cname); 4256: my @entries=(); 4257: my $time=time; 4258: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", 4259: &GDBM_WRCREAT(),0640)) { 4260: @entries=map { $_.':'.$hash{$_} } sort keys %hash; 4261: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); 4262: my ($thentime,$idnum)=split(/\_/,$lastid); 4263: my $newid=$time.'_000000'; 4264: if ($thentime==$time) { 4265: $idnum=~s/^0+//; 4266: $idnum++; 4267: $idnum=substr('000000'.$idnum,-6,6); 4268: $newid=$time.'_'.$idnum; 4269: } 4270: $hash{$newid}=$newchat; 4271: my $expired=$time-3600; 4272: foreach (keys %hash) { 4273: my ($thistime)=($_=~/(\d+)\_/); 4274: if ($thistime<$expired) { 4275: delete $hash{$_}; 4276: } 4277: } 4278: untie %hash; 4279: } 4280: { 4281: my $hfh; 4282: if ($hfh=IO::File->new(">>$proname/chatroom.log")) { 4283: print $hfh "$time:".&unescape($newchat)."\n"; 4284: } 4285: } 4286: } 4287: 4288: sub unsub { 4289: my ($fname,$clientip)=@_; 4290: my $result; 4291: if (unlink("$fname.$clientname")) { 4292: $result="ok\n"; 4293: } else { 4294: $result="not_subscribed\n"; 4295: } 4296: if (-e "$fname.subscription") { 4297: my $found=&addline($fname,$clientname,$clientip,''); 4298: if ($found) { $result="ok\n"; } 4299: } else { 4300: if ($result != "ok\n") { $result="not_subscribed\n"; } 4301: } 4302: return $result; 4303: } 4304: 4305: sub currentversion { 4306: my $fname=shift; 4307: my $version=-1; 4308: my $ulsdir=''; 4309: if ($fname=~/^(.+)\/[^\/]+$/) { 4310: $ulsdir=$1; 4311: } 4312: my ($fnamere1,$fnamere2); 4313: # remove version if already specified 4314: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; 4315: # get the bits that go before and after the version number 4316: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { 4317: $fnamere1=$1; 4318: $fnamere2='.'.$2; 4319: } 4320: if (-e $fname) { $version=1; } 4321: if (-e $ulsdir) { 4322: if(-d $ulsdir) { 4323: if (opendir(LSDIR,$ulsdir)) { 4324: my $ulsfn; 4325: while ($ulsfn=readdir(LSDIR)) { 4326: # see if this is a regular file (ignore links produced earlier) 4327: my $thisfile=$ulsdir.'/'.$ulsfn; 4328: unless (-l $thisfile) { 4329: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) { 4330: if ($1>$version) { $version=$1; } 4331: } 4332: } 4333: } 4334: closedir(LSDIR); 4335: $version++; 4336: } 4337: } 4338: } 4339: return $version; 4340: } 4341: 4342: sub thisversion { 4343: my $fname=shift; 4344: my $version=-1; 4345: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { 4346: $version=$1; 4347: } 4348: return $version; 4349: } 4350: 4351: sub subscribe { 4352: my ($userinput,$clientip)=@_; 4353: my $result; 4354: my ($cmd,$fname)=split(/:/,$userinput); 4355: my $ownership=&ishome($fname); 4356: if ($ownership eq 'owner') { 4357: # explitly asking for the current version? 4358: unless (-e $fname) { 4359: my $currentversion=&currentversion($fname); 4360: if (&thisversion($fname)==$currentversion) { 4361: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { 4362: my $root=$1; 4363: my $extension=$2; 4364: symlink($root.'.'.$extension, 4365: $root.'.'.$currentversion.'.'.$extension); 4366: unless ($extension=~/\.meta$/) { 4367: symlink($root.'.'.$extension.'.meta', 4368: $root.'.'.$currentversion.'.'.$extension.'.meta'); 4369: } 4370: } 4371: } 4372: } 4373: if (-e $fname) { 4374: if (-d $fname) { 4375: $result="directory\n"; 4376: } else { 4377: if (-e "$fname.$clientname") {&unsub($fname,$clientip);} 4378: my $now=time; 4379: my $found=&addline($fname,$clientname,$clientip, 4380: "$clientname:$clientip:$now\n"); 4381: if ($found) { $result="$fname\n"; } 4382: # if they were subscribed to only meta data, delete that 4383: # subscription, when you subscribe to a file you also get 4384: # the metadata 4385: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } 4386: $fname=~s/\/home\/httpd\/html\/res/raw/; 4387: $fname="http://$thisserver/".$fname; 4388: $result="$fname\n"; 4389: } 4390: } else { 4391: $result="not_found\n"; 4392: } 4393: } else { 4394: $result="rejected\n"; 4395: } 4396: return $result; 4397: } 4398: 4399: sub make_passwd_file { 4400: my ($uname, $umode,$npass,$passfilename)=@_; 4401: my $result="ok\n"; 4402: if ($umode eq 'krb4' or $umode eq 'krb5') { 4403: { 4404: my $pf = IO::File->new(">$passfilename"); 4405: print $pf "$umode:$npass\n"; 4406: } 4407: } elsif ($umode eq 'internal') { 4408: my $salt=time; 4409: $salt=substr($salt,6,2); 4410: my $ncpass=crypt($npass,$salt); 4411: { 4412: &Debug("Creating internal auth"); 4413: my $pf = IO::File->new(">$passfilename"); 4414: print $pf "internal:$ncpass\n"; 4415: } 4416: } elsif ($umode eq 'localauth') { 4417: { 4418: my $pf = IO::File->new(">$passfilename"); 4419: print $pf "localauth:$npass\n"; 4420: } 4421: } elsif ($umode eq 'unix') { 4422: { 4423: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; 4424: { 4425: &Debug("Executing external: ".$execpath); 4426: &Debug("user = ".$uname.", Password =". $npass); 4427: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); 4428: print $se "$uname\n"; 4429: print $se "$npass\n"; 4430: print $se "$npass\n"; 4431: } 4432: my $useraddok = $?; 4433: if($useraddok > 0) { 4434: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); 4435: } 4436: my $pf = IO::File->new(">$passfilename"); 4437: print $pf "unix:\n"; 4438: } 4439: } elsif ($umode eq 'none') { 4440: { 4441: my $pf = IO::File->new(">$passfilename"); 4442: print $pf "none:\n"; 4443: } 4444: } else { 4445: $result="auth_mode_error\n"; 4446: } 4447: return $result; 4448: } 4449: 4450: sub sethost { 4451: my ($remotereq) = @_; 4452: my (undef,$hostid)=split(/:/,$remotereq); 4453: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } 4454: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { 4455: $currenthostid=$hostid; 4456: $currentdomainid=$hostdom{$hostid}; 4457: &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); 4458: } else { 4459: &logthis("Requested host id $hostid not an alias of ". 4460: $perlvar{'lonHostID'}." refusing connection"); 4461: return 'unable_to_set'; 4462: } 4463: return 'ok'; 4464: } 4465: 4466: sub version { 4467: my ($userinput)=@_; 4468: $remoteVERSION=(split(/:/,$userinput))[1]; 4469: return "version:$VERSION"; 4470: } 4471: ############## >>>>>>>>>>>>>>>>>>>>>>>>>> FUTUREWORK <<<<<<<<<<<<<<<<<<<<<<<<<<<< 4472: #There is a copy of this in lonnet.pm 4473: # Can we hoist these lil' things out into common places? 4474: # 4475: sub userload { 4476: my $numusers=0; 4477: { 4478: opendir(LONIDS,$perlvar{'lonIDsDir'}); 4479: my $filename; 4480: my $curtime=time; 4481: while ($filename=readdir(LONIDS)) { 4482: if ($filename eq '.' || $filename eq '..') {next;} 4483: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; 4484: if ($curtime-$mtime < 1800) { $numusers++; } 4485: } 4486: closedir(LONIDS); 4487: } 4488: my $userloadpercent=0; 4489: my $maxuserload=$perlvar{'lonUserLoadLim'}; 4490: if ($maxuserload) { 4491: $userloadpercent=100*$numusers/$maxuserload; 4492: } 4493: $userloadpercent=sprintf("%.2f",$userloadpercent); 4494: return $userloadpercent; 4495: } 4496: 4497: # ----------------------------------- POD (plain old documentation, CPAN style) 4498: 4499: =head1 NAME 4500: 4501: lond - "LON Daemon" Server (port "LOND" 5663) 4502: 4503: =head1 SYNOPSIS 4504: 4505: Usage: B<lond> 4506: 4507: Should only be run as user=www. This is a command-line script which 4508: is invoked by B<loncron>. There is no expectation that a typical user 4509: will manually start B<lond> from the command-line. (In other words, 4510: DO NOT START B<lond> YOURSELF.) 4511: 4512: =head1 DESCRIPTION 4513: 4514: There are two characteristics associated with the running of B<lond>, 4515: PROCESS MANAGEMENT (starting, stopping, handling child processes) 4516: and SERVER-SIDE ACTIVITIES (password authentication, user creation, 4517: subscriptions, etc). These are described in two large 4518: sections below. 4519: 4520: B<PROCESS MANAGEMENT> 4521: 4522: Preforker - server who forks first. Runs as a daemon. HUPs. 4523: Uses IDEA encryption 4524: 4525: B<lond> forks off children processes that correspond to the other servers 4526: in the network. Management of these processes can be done at the 4527: parent process level or the child process level. 4528: 4529: B<logs/lond.log> is the location of log messages. 4530: 4531: The process management is now explained in terms of linux shell commands, 4532: subroutines internal to this code, and signal assignments: 4533: 4534: =over 4 4535: 4536: =item * 4537: 4538: PID is stored in B<logs/lond.pid> 4539: 4540: This is the process id number of the parent B<lond> process. 4541: 4542: =item * 4543: 4544: SIGTERM and SIGINT 4545: 4546: Parent signal assignment: 4547: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 4548: 4549: Child signal assignment: 4550: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) 4551: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber 4552: to restart a new child.) 4553: 4554: Command-line invocations: 4555: B<kill> B<-s> SIGTERM I<PID> 4556: B<kill> B<-s> SIGINT I<PID> 4557: 4558: Subroutine B<HUNTSMAN>: 4559: This is only invoked for the B<lond> parent I<PID>. 4560: This kills all the children, and then the parent. 4561: The B<lonc.pid> file is cleared. 4562: 4563: =item * 4564: 4565: SIGHUP 4566: 4567: Current bug: 4568: This signal can only be processed the first time 4569: on the parent process. Subsequent SIGHUP signals 4570: have no effect. 4571: 4572: Parent signal assignment: 4573: $SIG{HUP} = \&HUPSMAN; 4574: 4575: Child signal assignment: 4576: none (nothing happens) 4577: 4578: Command-line invocations: 4579: B<kill> B<-s> SIGHUP I<PID> 4580: 4581: Subroutine B<HUPSMAN>: 4582: This is only invoked for the B<lond> parent I<PID>, 4583: This kills all the children, and then the parent. 4584: The B<lond.pid> file is cleared. 4585: 4586: =item * 4587: 4588: SIGUSR1 4589: 4590: Parent signal assignment: 4591: $SIG{USR1} = \&USRMAN; 4592: 4593: Child signal assignment: 4594: $SIG{USR1}= \&logstatus; 4595: 4596: Command-line invocations: 4597: B<kill> B<-s> SIGUSR1 I<PID> 4598: 4599: Subroutine B<USRMAN>: 4600: When invoked for the B<lond> parent I<PID>, 4601: SIGUSR1 is sent to all the children, and the status of 4602: each connection is logged. 4603: 4604: =item * 4605: 4606: SIGUSR2 4607: 4608: Parent Signal assignment: 4609: $SIG{USR2} = \&UpdateHosts 4610: 4611: Child signal assignment: 4612: NONE 4613: 4614: 4615: =item * 4616: 4617: SIGCHLD 4618: 4619: Parent signal assignment: 4620: $SIG{CHLD} = \&REAPER; 4621: 4622: Child signal assignment: 4623: none 4624: 4625: Command-line invocations: 4626: B<kill> B<-s> SIGCHLD I<PID> 4627: 4628: Subroutine B<REAPER>: 4629: This is only invoked for the B<lond> parent I<PID>. 4630: Information pertaining to the child is removed. 4631: The socket port is cleaned up. 4632: 4633: =back 4634: 4635: B<SERVER-SIDE ACTIVITIES> 4636: 4637: Server-side information can be accepted in an encrypted or non-encrypted 4638: method. 4639: 4640: =over 4 4641: 4642: =item ping 4643: 4644: Query a client in the hosts.tab table; "Are you there?" 4645: 4646: =item pong 4647: 4648: Respond to a ping query. 4649: 4650: =item ekey 4651: 4652: Read in encrypted key, make cipher. Respond with a buildkey. 4653: 4654: =item load 4655: 4656: Respond with CPU load based on a computation upon /proc/loadavg. 4657: 4658: =item currentauth 4659: 4660: Reply with current authentication information (only over an 4661: encrypted channel). 4662: 4663: =item auth 4664: 4665: Only over an encrypted channel, reply as to whether a user's 4666: authentication information can be validated. 4667: 4668: =item passwd 4669: 4670: Allow for a password to be set. 4671: 4672: =item makeuser 4673: 4674: Make a user. 4675: 4676: =item passwd 4677: 4678: Allow for authentication mechanism and password to be changed. 4679: 4680: =item home 4681: 4682: Respond to a question "are you the home for a given user?" 4683: 4684: =item update 4685: 4686: Update contents of a subscribed resource. 4687: 4688: =item unsubscribe 4689: 4690: The server is unsubscribing from a resource. 4691: 4692: =item subscribe 4693: 4694: The server is subscribing to a resource. 4695: 4696: =item log 4697: 4698: Place in B<logs/lond.log> 4699: 4700: =item put 4701: 4702: stores hash in namespace 4703: 4704: =item rolesput 4705: 4706: put a role into a user's environment 4707: 4708: =item get 4709: 4710: returns hash with keys from array 4711: reference filled in from namespace 4712: 4713: =item eget 4714: 4715: returns hash with keys from array 4716: reference filled in from namesp (encrypts the return communication) 4717: 4718: =item rolesget 4719: 4720: get a role from a user's environment 4721: 4722: =item del 4723: 4724: deletes keys out of array from namespace 4725: 4726: =item keys 4727: 4728: returns namespace keys 4729: 4730: =item dump 4731: 4732: dumps the complete (or key matching regexp) namespace into a hash 4733: 4734: =item store 4735: 4736: stores hash permanently 4737: for this url; hashref needs to be given and should be a \%hashname; the 4738: remaining args aren't required and if they aren't passed or are '' they will 4739: be derived from the ENV 4740: 4741: =item restore 4742: 4743: returns a hash for a given url 4744: 4745: =item querysend 4746: 4747: Tells client about the lonsql process that has been launched in response 4748: to a sent query. 4749: 4750: =item queryreply 4751: 4752: Accept information from lonsql and make appropriate storage in temporary 4753: file space. 4754: 4755: =item idput 4756: 4757: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers 4758: for each student, defined perhaps by the institutional Registrar.) 4759: 4760: =item idget 4761: 4762: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers 4763: for each student, defined perhaps by the institutional Registrar.) 4764: 4765: =item tmpput 4766: 4767: Accept and store information in temporary space. 4768: 4769: =item tmpget 4770: 4771: Send along temporarily stored information. 4772: 4773: =item ls 4774: 4775: List part of a user's directory. 4776: 4777: =item pushtable 4778: 4779: Pushes a file in /home/httpd/lonTab directory. Currently limited to: 4780: hosts.tab and domain.tab. The old file is copied to *.tab.backup but 4781: must be restored manually in case of a problem with the new table file. 4782: pushtable requires that the request be encrypted and validated via 4783: ValidateManager. The form of the command is: 4784: enc:pushtable tablename <tablecontents> \n 4785: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a 4786: cleartext newline. 4787: 4788: =item Hanging up (exit or init) 4789: 4790: What to do when a client tells the server that they (the client) 4791: are leaving the network. 4792: 4793: =item unknown command 4794: 4795: If B<lond> is sent an unknown command (not in the list above), 4796: it replys to the client "unknown_cmd". 4797: 4798: 4799: =item UNKNOWN CLIENT 4800: 4801: If the anti-spoofing algorithm cannot verify the client, 4802: the client is rejected (with a "refused" message sent 4803: to the client, and the connection is closed. 4804: 4805: =back 4806: 4807: =head1 PREREQUISITES 4808: 4809: IO::Socket 4810: IO::File 4811: Apache::File 4812: Symbol 4813: POSIX 4814: Crypt::IDEA 4815: LWP::UserAgent() 4816: GDBM_File 4817: Authen::Krb4 4818: Authen::Krb5 4819: 4820: =head1 COREQUISITES 4821: 4822: =head1 OSNAMES 4823: 4824: linux 4825: 4826: =head1 SCRIPT CATEGORIES 4827: 4828: Server/Process 4829: 4830: =cut