loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.178.2.5: download - view: text, annotated - select for diffs
Tue Feb 24 16:52:16 2004 UTC (20 years, 2 months ago) by albertel
Branches: Refactoring

- don't study reg exp, student the string

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