loncom/lond - view

File: [LON-CAPA] / loncom / lond
Revision 1.178.2.7: download - view: text, annotated - select for diffs
Mon Mar 8 21:54:05 2004 UTC (20 years, 8 months ago) by foxr
Branches: Refactoring

Fix 2 minor errors;
- inc error messages led people to believe the errors were in put.
- in the inc handler, I did not properly reconstruct $userinput for Failure.

1: #!/usr/bin/perl 2: # The LearningOnline Network 3: # lond "LON Daemon" Server (port "LOND" 5663) 4: # 5: # $Id: lond,v 1.178.2.7 2004/03/08 21:54:05 foxr Exp $ 6: # 7: # Copyright Michigan State University Board of Trustees 8: # 9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 10: # 11: # LON-CAPA is free software; you can redistribute it and/or modify 12: # it under the terms of the GNU General Public License as published by 13: # the Free Software Foundation; either version 2 of the License, or 14: # (at your option) any later version. 15: # 16: # LON-CAPA is distributed in the hope that it will be useful, 17: # but WITHOUT ANY WARRANTY; without even the implied warranty of 18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19: # GNU General Public License for more details. 20: # 21: # You should have received a copy of the GNU General Public License 22: # along with LON-CAPA; if not, write to the Free Software 23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 24: # 25: # /home/httpd/html/adm/gpl.txt 26: # 27: 28: 29: # http://www.lon-capa.org/ 30: # 31: 32: use strict; 33: use lib '/home/httpd/lib/perl/'; 34: use LONCAPA::Configuration; 35: 36: use IO::Socket; 37: use IO::File; 38: #use Apache::File; 39: use Symbol; 40: use POSIX; 41: use Crypt::IDEA; 42: use LWP::UserAgent(); 43: use GDBM_File; 44: use Authen::Krb4; 45: use Authen::Krb5; 46: use lib '/home/httpd/lib/perl/'; 47: use localauth; 48: use File::Copy; 49: use LONCAPA::ConfigFileEdit; 50: 51: my $DEBUG = 1; # Non zero to enable debug log entries. 52: 53: my $status=''; 54: my $lastlog=''; 55: 56: my $VERSION='$Revision: 1.178.2.7 $'; #' 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 = "$cmd:$tail"; 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 inc\n", $userinput); 1395: } 1396: } else { 1397: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 1398: "while attempting inc\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: 1676: sub DeleteProfileEntry { 1677: my $cmd = shift; 1678: my $tail = shift; 1679: my $client = shift; 1680: my $userinput = "cmd:$tail"; 1681: 1682: my ($udom,$uname,$namespace,$what) = split(/:/,$tail); 1683: $namespace=~s/\//\_/g; 1684: $namespace=~s/\W//g; 1685: chomp($what); 1686: my $proname=propath($udom,$uname); 1687: my $now=time; 1688: unless ($namespace=~/^nohist\_/) { 1689: my $hfh; 1690: if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 1691: print $hfh "D:$now:$what\n"; 1692: } 1693: } 1694: my @keys=split(/\&/,$what); 1695: my %hash; 1696: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { 1697: foreach my $key (@keys) { 1698: delete($hash{$key}); 1699: } 1700: if (untie(%hash)) { 1701: Reply($client, "ok\n", $userinput); 1702: } else { 1703: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 1704: "while attempting del\n", $userinput); 1705: } 1706: } else { 1707: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 1708: "while attempting del\n", $userinput); 1709: } 1710: return 1; 1711: } 1712: RegisterHandler("del", \&DeleteProfileEntry, 0, 1, 0); 1713: # 1714: # List the set of keys that are defined in a profile database file. 1715: # A successful reply from this will contain an & separated list of 1716: # the keys. 1717: # Parameters: 1718: # $cmd - Command request (keys). 1719: # $tail - Remainder of the request, a colon separated 1720: # list containing domain/user that identifies the 1721: # user being queried, and the database namespace 1722: # (database filename essentially). 1723: # $client - File open on the client. 1724: # Returns: 1725: # 1 - Continue processing. 1726: # 0 - Exit the server. 1727: # 1728: sub GetProfileKeys { 1729: my $cmd = shift; 1730: my $tail = shift; 1731: my $client = shift; 1732: my $userinput = "$cmd:$tail"; 1733: 1734: my ($udom,$uname,$namespace)=split(/:/,$tail); 1735: $namespace=~s/\//\_/g; 1736: $namespace=~s/\W//g; 1737: my $proname=propath($udom,$uname); 1738: my $qresult=''; 1739: my %hash; 1740: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { 1741: foreach my $key (keys %hash) { 1742: $qresult.="$key&"; 1743: } 1744: if (untie(%hash)) { 1745: $qresult=~s/\&$//; 1746: Reply($client, "$qresult\n", $userinput); 1747: } else { 1748: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 1749: "while attempting keys\n", $userinput); 1750: } 1751: } else { 1752: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 1753: "while attempting keys\n", $userinput); 1754: } 1755: 1756: return 1; 1757: } 1758: RegisterHandler("keys", \&GetProfileKeys, 0, 1, 0); 1759: # 1760: # Dump the contents of a user profile database. 1761: # Note that this constitutes a very large covert channel too since 1762: # the dump will return sensitive information that is not encrypted. 1763: # The naive security assumption is that the session negotiation ensures 1764: # our client is trusted and I don't believe that's assured at present. 1765: # Sure want badly to go to ssl or tls. Of course if my peer isn't really 1766: # a LonCAPA node they could have negotiated an encryption key too so >sigh<. 1767: # 1768: # Parameters: 1769: # $cmd - The command request keyword (currentdump). 1770: # $tail - Remainder of the request, consisting of a colon 1771: # separated list that has the domain/username and 1772: # the namespace to dump (database file). 1773: # $client - file open on the remote client. 1774: # Returns: 1775: # 1 - Continue processing. 1776: # 0 - Exit the server. 1777: # 1778: sub DumpProfileDatabase { 1779: my $cmd = shift; 1780: my $tail = shift; 1781: my $client = shift; 1782: my $userinput = "$cmd:$tail"; 1783: 1784: my ($udom,$uname,$namespace) = split(/:/,$tail); 1785: $namespace=~s/\//\_/g; 1786: $namespace=~s/\W//g; 1787: my $qresult=''; 1788: my $proname=propath($udom,$uname); 1789: my %hash; 1790: if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_READER(),0640)) { 1791: # Structure of %data: 1792: # $data{$symb}->{$parameter}=$value; 1793: # $data{$symb}->{'v.'.$parameter}=$version; 1794: # since $parameter will be unescaped, we do not 1795: # have to worry about silly parameter names... 1796: my %data = (); # A hash of anonymous hashes.. 1797: while (my ($key,$value) = each(%hash)) { 1798: my ($v,$symb,$param) = split(/:/,$key); 1799: next if ($v eq 'version' || $symb eq 'keys'); 1800: next if (exists($data{$symb}) && 1801: exists($data{$symb}->{$param}) && 1802: $data{$symb}->{'v.'.$param} > $v); 1803: $data{$symb}->{$param}=$value; 1804: $data{$symb}->{'v.'.$param}=$v; 1805: } 1806: if (untie(%hash)) { 1807: while (my ($symb,$param_hash) = each(%data)) { 1808: while(my ($param,$value) = each (%$param_hash)){ 1809: next if ($param =~ /^v\./); # Ignore versions... 1810: # 1811: # Just dump the symb=value pairs separated by & 1812: # 1813: $qresult.=$symb.':'.$param.'='.$value.'&'; 1814: } 1815: } 1816: chop($qresult); 1817: Reply($client , "$qresult\n", $userinput); 1818: } else { 1819: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 1820: "while attempting currentdump\n", $userinput); 1821: } 1822: } else { 1823: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 1824: "while attempting currentdump\n", $userinput); 1825: } 1826: 1827: return 1; 1828: } 1829: RegisterHandler("currentdump", \&DumpProfileDatabase, 0, 1, 0); 1830: # 1831: # Dump a profile database with an optional regular expression 1832: # to match against the keys. In this dump, no effort is made 1833: # to separate symb from version information. Presumably the 1834: # databases that are dumped by this command are of a different 1835: # structure. Need to look at this and improve the documentation of 1836: # both this and the currentdump handler. 1837: # Parameters: 1838: # $cmd - The command keyword. 1839: # $tail - All of the characters after the $cmd: 1840: # These are expected to be a colon 1841: # separated list containing: 1842: # domain/user - identifying the user. 1843: # namespace - identifying the database. 1844: # regexp - optional regular expression 1845: # that is matched against 1846: # database keywords to do 1847: # selective dumps. 1848: # $client - Channel open on the client. 1849: # Returns: 1850: # 1 - Continue processing. 1851: # Side effects: 1852: # response is written to $client. 1853: # 1854: sub DumpWithRegexp { 1855: my $cmd = shift; 1856: my $tail = shift; 1857: my $client = shift; 1858: 1859: my $userinput = "$cmd:$tail"; 1860: 1861: my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); 1862: $namespace=~s/\//\_/g; 1863: $namespace=~s/\W//g; 1864: if (defined($regexp)) { 1865: $regexp=&unescape($regexp); 1866: } else { 1867: $regexp='.'; 1868: } 1869: my $qresult=''; 1870: my $proname=propath($udom,$uname); 1871: my %hash; 1872: if (tie(%hash,'GDBM_File',"$proname/$namespace.db", 1873: &GDBM_READER(),0640)) { 1874: while (my ($key,$value) = each(%hash)) { 1875: if ($regexp eq '.') { 1876: $qresult.=$key.'='.$value.'&'; 1877: } else { 1878: my $unescapeKey = &unescape($key); 1879: if (eval('$unescapeKey=~/$regexp/')) { 1880: $qresult.="$key=$value&"; 1881: } 1882: } 1883: } 1884: if (untie(%hash)) { 1885: chop($qresult); 1886: Reply($client, "$qresult\n", $userinput); 1887: } else { 1888: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 1889: "while attempting dump\n", $userinput); 1890: } 1891: } else { 1892: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 1893: "while attempting dump\n", $userinput); 1894: } 1895: 1896: return 1; 1897: } 1898: RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0); 1899: 1900: # Store an aitem in any database but the roles database. 1901: # 1902: # Parameters: 1903: # $cmd - Request command keyword. 1904: # $tail - Tail of the request. This is a colon 1905: # separated list containing: 1906: # domain/user - User and authentication domain. 1907: # namespace - Name of the database being modified 1908: # rid - Resource keyword to modify. 1909: # what - new value associated with rid. 1910: # 1911: # $client - Socket open on the client. 1912: # 1913: # 1914: # Returns: 1915: # 1 (keep on processing). 1916: # Side-Effects: 1917: # Writes to the client 1918: sub StoreHandler { 1919: my $cmd = shift; 1920: my $tail = shift; 1921: my $client = shift; 1922: 1923: my $userinput = "$cmd:$tail"; 1924: 1925: my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail); 1926: $namespace=~s/\//\_/g; 1927: $namespace=~s/\W//g; 1928: if ($namespace ne 'roles') { 1929: chomp($what); 1930: my $proname=propath($udom,$uname); 1931: my $now=time; 1932: unless ($namespace=~/^nohist\_/) { 1933: my $hfh; 1934: if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 1935: print $hfh "P:$now:$rid:$what\n"; 1936: } 1937: } 1938: my @pairs=split(/\&/,$what); 1939: my %hash; 1940: if (tie(%hash,'GDBM_File',"$proname/$namespace.db", 1941: &GDBM_WRCREAT(),0640)) { 1942: my @previouskeys=split(/&/,$hash{"keys:$rid"}); 1943: my $key; 1944: $hash{"version:$rid"}++; 1945: my $version=$hash{"version:$rid"}; 1946: my $allkeys=''; 1947: foreach my $pair (@pairs) { 1948: my ($key,$value)=split(/=/,$pair); 1949: $allkeys.=$key.':'; 1950: $hash{"$version:$rid:$key"}=$value; 1951: } 1952: $hash{"$version:$rid:timestamp"}=$now; 1953: $allkeys.='timestamp'; 1954: $hash{"$version:keys:$rid"}=$allkeys; 1955: if (untie(%hash)) { 1956: Reply($client, "ok\n", $userinput); 1957: } else { 1958: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 1959: "while attempting store\n", $userinput); 1960: } 1961: } else { 1962: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 1963: "while attempting store\n", $userinput); 1964: } 1965: } else { 1966: Failure($client, "refused\n", $userinput); 1967: } 1968: 1969: return 1; 1970: } 1971: RegisterHandler("store", \&StoreHandler, 0, 1, 0); 1972: # 1973: # Restore a prior version of a resource. 1974: # 1975: # Parameters: 1976: # $cmd - Command keyword. 1977: # $tail - Remainder of the request which consists of: 1978: # domain/user - User and auth. domain. 1979: # namespace - name of resource database. 1980: # rid - Resource id. 1981: # $client - socket open on the client. 1982: # 1983: # Returns: 1984: # 1 indicating the caller should not yet exit. 1985: # Side-effects: 1986: # Writes a reply to the client. 1987: # 1988: sub RestoreHandler { 1989: my $cmd = shift; 1990: my $tail = shift; 1991: my $client = shift; 1992: 1993: my $userinput = "$cmd:$tail"; # Only used for logging purposes. 1994: 1995: my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput); 1996: $namespace=~s/\//\_/g; 1997: $namespace=~s/\W//g; 1998: chomp($rid); 1999: my $proname=propath($udom,$uname); 2000: my $qresult=''; 2001: my %hash; 2002: if (tie(%hash,'GDBM_File',"$proname/$namespace.db", 2003: &GDBM_READER(),0640)) { 2004: my $version=$hash{"version:$rid"}; 2005: $qresult.="version=$version&"; 2006: my $scope; 2007: for ($scope=1;$scope<=$version;$scope++) { 2008: my $vkeys=$hash{"$scope:keys:$rid"}; 2009: my @keys=split(/:/,$vkeys); 2010: my $key; 2011: $qresult.="$scope:keys=$vkeys&"; 2012: foreach $key (@keys) { 2013: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; 2014: } 2015: } 2016: if (untie(%hash)) { 2017: $qresult=~s/\&$//; 2018: Reply( $client, "$qresult\n", $userinput); 2019: } else { 2020: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2021: "while attempting restore\n", $userinput); 2022: } 2023: } else { 2024: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2025: "while attempting restore\n", $userinput); 2026: } 2027: 2028: return 1; 2029: 2030: 2031: } 2032: RegisterHandler("restore", \&RestoreHandler, 0,1,0); 2033: 2034: # 2035: # Add a chat message to to a discussion board. 2036: # 2037: # Parameters: 2038: # $cmd - Request keyword. 2039: # $tail - Tail of the command. A colon separated list 2040: # containing: 2041: # cdom - Domain on which the chat board lives 2042: # cnum - Identifier of the discussion group. 2043: # post - Body of the posting. 2044: # $client - Socket open on the client. 2045: # Returns: 2046: # 1 - Indicating caller should keep on processing. 2047: # 2048: # Side-effects: 2049: # writes a reply to the client. 2050: # 2051: # 2052: sub SendChatHandler { 2053: my $cmd = shift; 2054: my $tail = shift; 2055: my $client = shift; 2056: 2057: my $userinput = "$cmd:$tail"; 2058: 2059: my ($cdom,$cnum,$newpost)=split(/\:/,$tail); 2060: &chatadd($cdom,$cnum,$newpost); 2061: Reply($client, "ok\n", $userinput); 2062: 2063: return 1; 2064: } 2065: RegisterHandler("chatsend", \&SendChatHandler, 0, 1, 0); 2066: # 2067: # Retrieve the set of chat messagss from a discussion board. 2068: # 2069: # Parameters: 2070: # $cmd - Command keyword that initiated the request. 2071: # $tail - Remainder of the request after the command 2072: # keyword. In this case a colon separated list of 2073: # chat domain - Which discussion board. 2074: # chat id - Discussion thread(?) 2075: # domain/user - Authentication domain and username 2076: # of the requesting person. 2077: # $client - Socket open on the client program. 2078: # Returns: 2079: # 1 - continue processing 2080: # Side effects: 2081: # Response is written to the client. 2082: # 2083: sub RetrieveChatHandler { 2084: my $cmd = shift; 2085: my $tail = shift; 2086: my $client = shift; 2087: 2088: my $userinput = "$cmd:$tail"; 2089: 2090: my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail); 2091: my $reply=''; 2092: foreach (&getchat($cdom,$cnum,$udom,$uname)) { 2093: $reply.=&escape($_).':'; 2094: } 2095: $reply=~s/\:$//; 2096: Reply($client, $reply."\n", $userinput); 2097: 2098: 2099: return 1; 2100: } 2101: RegisterHandler("chatretr", \&RetrieveChatHandler, 0, 1, 0); 2102: # 2103: # Initiate a query of an sql database. SQL query repsonses get put in 2104: # a file for later retrieval. This prevents sql query results from 2105: # bottlenecking the system. Note that with loncnew, perhaps this is 2106: # less of an issue since multiple outstanding requests can be concurrently 2107: # serviced. 2108: # 2109: # Parameters: 2110: # $cmd - COmmand keyword that initiated the request. 2111: # $tail - Remainder of the command after the keyword. 2112: # For this function, this consists of a query and 2113: # 3 arguments that are self-documentingly labelled 2114: # in the original arg1, arg2, arg3. 2115: # $client - Socket open on the client. 2116: # Return: 2117: # 1 - Indicating processing should continue. 2118: # Side-effects: 2119: # a reply is written to $client. 2120: # 2121: sub SendQueryHandler { 2122: my $cmd = shift; 2123: my $tail = shift; 2124: my $client = shift; 2125: 2126: my $userinput = "$cmd:$tail"; 2127: 2128: my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail); 2129: $query=~s/\n*$//g; 2130: Reply($client, "". sqlreply("$clientname\&$query". 2131: "\&$arg1"."\&$arg2"."\&$arg3")."\n", 2132: $userinput); 2133: 2134: return 1; 2135: } 2136: RegisterHandler("querysend", \&SendQueryHandler, 0, 1, 0); 2137: 2138: # 2139: # Add a reply to an sql query. SQL queries are done asyncrhonously. 2140: # The query is submitted via a "querysend" transaction. 2141: # There it is passed on to the lonsql daemon, queued and issued to 2142: # mysql. 2143: # This transaction is invoked when the sql transaction is complete 2144: # it stores the query results in flie and indicates query completion. 2145: # presumably local software then fetches this response... I'm guessing 2146: # the sequence is: lonc does a querysend, we ask lonsql to do it. 2147: # lonsql on completion of the query interacts with the lond of our 2148: # client to do a query reply storing two files: 2149: # - id - The results of the query. 2150: # - id.end - Indicating the transaction completed. 2151: # NOTE: id is a unique id assigned to the query and querysend time. 2152: # Parameters: 2153: # $cmd - Command keyword that initiated this request. 2154: # $tail - Remainder of the tail. In this case that's a colon 2155: # separated list containing the query Id and the 2156: # results of the query. 2157: # $client - Socket open on the client. 2158: # Return: 2159: # 1 - Indicating that we should continue processing. 2160: # Side effects: 2161: # ok written to the client. 2162: # 2163: sub ReplyQueryHandler { 2164: my $cmd = shift; 2165: my $tail = shift; 2166: my $client = shift; 2167: 2168: my $userinput = "$cmd:$tail"; 2169: 2170: my ($cmd,$id,$reply)=split(/:/,$userinput); 2171: my $store; 2172: my $execdir=$perlvar{'lonDaemons'}; 2173: if ($store=IO::File->new(">$execdir/tmp/$id")) { 2174: $reply=~s/\&/\n/g; 2175: print $store $reply; 2176: close $store; 2177: my $store2=IO::File->new(">$execdir/tmp/$id.end"); 2178: print $store2 "done\n"; 2179: close $store2; 2180: Reply($client, "ok\n", $userinput); 2181: } else { 2182: Failure($client, "error: ".($!+0) 2183: ." IO::File->new Failed ". 2184: "while attempting queryreply\n", $userinput); 2185: } 2186: 2187: 2188: return 1; 2189: } 2190: RegisterHandler("queryreply", \&ReplyQueryHandler, 0, 1, 0); 2191: # 2192: # Process the courseidput query. Not quite sure what this means 2193: # at the system level sense. It appears a gdbm file in the 2194: # /home/httpd/lonUsers/$domain/nohist_courseids is tied and 2195: # a set of entries made in that database. 2196: # 2197: # Parameters: 2198: # $cmd - The command keyword that initiated this request. 2199: # $tail - Tail of the command. In this case consists of a colon 2200: # separated list contaning the domain to apply this to and 2201: # an ampersand separated list of keyword=value pairs. 2202: # $client - Socket open on the client. 2203: # Returns: 2204: # 1 - indicating that processing should continue 2205: # 2206: # Side effects: 2207: # reply is written to the client. 2208: # 2209: sub PutCourseIdHandler { 2210: my $cmd = shift; 2211: my $tail = shift; 2212: my $client = shift; 2213: 2214: my $userinput = "$cmd:$tail"; 2215: 2216: my ($udom,$what)=split(/:/,$tail); 2217: chomp($what); 2218: $udom=~s/\W//g; 2219: my $proname= 2220: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; 2221: my $now=time; 2222: my @pairs=split(/\&/,$what); 2223: my %hash; 2224: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { 2225: foreach my $pair (@pairs) { 2226: my ($key,$value)=split(/=/,$pair); 2227: $hash{$key}=$value.':'.$now; 2228: } 2229: if (untie(%hash)) { 2230: Reply($client, "ok\n", $userinput); 2231: } else { 2232: Failure( $client, "error: ".($!+0) 2233: ." untie(GDBM) Failed ". 2234: "while attempting courseidput\n", $userinput); 2235: } 2236: } else { 2237: Failure( $client, "error: ".($!+0) 2238: ." tie(GDBM) Failed ". 2239: "while attempting courseidput\n", $userinput); 2240: } 2241: 2242: return 1; 2243: } 2244: RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0); 2245: 2246: # Retrieves the value of a course id resource keyword pattern 2247: # defined since a starting date. Both the starting date and the 2248: # keyword pattern are optional. If the starting date is not supplied it 2249: # is treated as the beginning of time. If the pattern is not found, 2250: # it is treatred as "." matching everything. 2251: # 2252: # Parameters: 2253: # $cmd - Command keyword that resulted in us being dispatched. 2254: # $tail - The remainder of the command that, in this case, consists 2255: # of a colon separated list of: 2256: # domain - The domain in which the course database is 2257: # defined. 2258: # since - Optional parameter describing the minimum 2259: # time of definition(?) of the resources that 2260: # will match the dump. 2261: # description - regular expression that is used to filter 2262: # the dump. Only keywords matching this regexp 2263: # will be used. 2264: # $client - The socket open on the client. 2265: # Returns: 2266: # 1 - Continue processing. 2267: # Side Effects: 2268: # a reply is written to $client. 2269: sub DumpCourseIdHandler { 2270: my $cmd = shift; 2271: my $tail = shift; 2272: my $client = shift; 2273: 2274: my $userinput = "$cmd:$tail"; 2275: 2276: my ($udom,$since,$description) =split(/:/,$tail); 2277: if (defined($description)) { 2278: $description=&unescape($description); 2279: } else { 2280: $description='.'; 2281: } 2282: unless (defined($since)) { $since=0; } 2283: my $qresult=''; 2284: my $proname = "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; 2285: my %hash; 2286: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { 2287: while (my ($key,$value) = each(%hash)) { 2288: my ($descr,$lasttime)=split(/\:/,$value); 2289: if ($lasttime<$since) { 2290: next; 2291: } 2292: if ($description eq '.') { 2293: $qresult.=$key.'='.$descr.'&'; 2294: } else { 2295: my $unescapeVal = &unescape($descr); 2296: if (eval('$unescapeVal=~/$description/i')) { 2297: $qresult.="$key=$descr&"; 2298: } 2299: } 2300: } 2301: if (untie(%hash)) { 2302: chop($qresult); 2303: Reply($client, "$qresult\n", $userinput); 2304: } else { 2305: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2306: "while attempting courseiddump\n", $userinput); 2307: } 2308: } else { 2309: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2310: "while attempting courseiddump\n", $userinput); 2311: } 2312: 2313: 2314: return 1; 2315: } 2316: RegisterHandler("courseiddump", \&DumpCourseIdHandler, 0, 1, 0); 2317: # 2318: # Puts an id to a domains id database. 2319: # 2320: # Parameters: 2321: # $cmd - The command that triggered us. 2322: # $tail - Remainder of the request other than the command. This is a 2323: # colon separated list containing: 2324: # $domain - The domain for which we are writing the id. 2325: # $pairs - The id info to write... this is and & separated list 2326: # of keyword=value. 2327: # $client - Socket open on the client. 2328: # Returns: 2329: # 1 - Continue processing. 2330: # Side effects: 2331: # reply is written to $client. 2332: # 2333: sub PutIdHandler { 2334: my $cmd = shift; 2335: my $tail = shift; 2336: my $client = shift; 2337: 2338: my $userinput = "$cmd:$tail"; 2339: 2340: my ($udom,$what)=split(/:/,$tail); 2341: chomp($what); 2342: $udom=~s/\W//g; 2343: my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; 2344: my $now=time; 2345: { 2346: my $hfh; 2347: if ($hfh=IO::File->new(">>$proname.hist")) { 2348: print $hfh "P:$now:$what\n"; 2349: } 2350: } 2351: my @pairs=split(/\&/,$what); 2352: my %hash; 2353: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { 2354: foreach my $pair (@pairs) { 2355: my ($key,$value)=split(/=/,$pair); 2356: $hash{$key}=$value; 2357: } 2358: if (untie(%hash)) { 2359: Reply($client, "ok\n", $userinput); 2360: } else { 2361: Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". 2362: "while attempting idput\n", $userinput); 2363: } 2364: } else { 2365: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". 2366: "while attempting idput\n", $userinput); 2367: } 2368: 2369: return 1; 2370: } 2371: 2372: RegisterHandler("idput", \&PutIdHandler, 0, 1, 0); 2373: # 2374: # Retrieves a set of id values from the id database. 2375: # Returns an & separated list of results, one for each requested id to the 2376: # client. 2377: # 2378: # Parameters: 2379: # $cmd - Command keyword that caused us to be dispatched. 2380: # $tail - Tail of the command. Consists of a colon separated: 2381: # domain - the domain whose id table we dump 2382: # ids Consists of an & separated list of 2383: # id keywords whose values will be fetched. 2384: # nonexisting keywords will have an empty value. 2385: # $client - Socket open on the client. 2386: # 2387: # Returns: 2388: # 1 - indicating processing should continue. 2389: # Side effects: 2390: # An & separated list of results is written to $client. 2391: # 2392: sub GetIdHandler { 2393: my $cmd = shift; 2394: my $tail = shift; 2395: my $client = shift; 2396: 2397: my $userinput = "$client:$tail"; 2398: 2399: my ($udom,$what)=split(/:/,$tail); 2400: chomp($what); 2401: $udom=~s/\W//g; 2402: my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; 2403: my @queries=split(/\&/,$what); 2404: my $qresult=''; 2405: my %hash; 2406: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { 2407: for (my $i=0;$i<=$#queries;$i++) { 2408: $qresult.="$hash{$queries[$i]}&"; 2409: } 2410: if (untie(%hash)) { 2411: $qresult=~s/\&$//; 2412: Reply($client, "$qresult\n", $userinput); 2413: } else { 2414: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". 2415: "while attempting idget\n",$userinput); 2416: } 2417: } else { 2418: Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". 2419: "while attempting idget\n",$userinput); 2420: } 2421: 2422: return 1; 2423: } 2424: 2425: RegisterHandler("idget", \&GetIdHandler, 0, 1, 0); 2426: # 2427: # Process the tmpput command I'm not sure what this does.. Seems to 2428: # create a file in the lonDaemons/tmp directory of the form $id.tmp 2429: # where Id is the client's ip concatenated with a sequence number. 2430: # The file will contain some value that is passed in. Is this e.g. 2431: # a login token? 2432: # 2433: # Parameters: 2434: # $cmd - The command that got us dispatched. 2435: # $tail - The remainder of the request following $cmd: 2436: # In this case this will be the contents of the file. 2437: # $client - Socket connected to the client. 2438: # Returns: 2439: # 1 indicating processing can continue. 2440: # Side effects: 2441: # A file is created in the local filesystem. 2442: # A reply is sent to the client. 2443: sub TmpPutHandler { 2444: my $cmd = shift; 2445: my $what = shift; 2446: my $client = shift; 2447: 2448: my $userinput = "$cmd:$what"; # Reconstruct for logging. 2449: 2450: 2451: my $store; 2452: $tmpsnum++; 2453: my $id=$$.'_'.$clientip.'_'.$tmpsnum; 2454: $id=~s/\W/\_/g; 2455: $what=~s/\n//g; 2456: my $execdir=$perlvar{'lonDaemons'}; 2457: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { 2458: print $store $what; 2459: close $store; 2460: Reply($client, "$id\n", $userinput); 2461: } else { 2462: Failure( $client, "error: ".($!+0)."IO::File->new Failed ". 2463: "while attempting tmpput\n", $userinput); 2464: } 2465: return 1; 2466: 2467: } 2468: RegisterHandler("tmpput", \&TmpPutHandler, 0, 1, 0); 2469: 2470: # Processes the tmpget command. This command returns the contents 2471: # of a temporary resource file(?) created via tmpput. 2472: # 2473: # Paramters: 2474: # $cmd - Command that got us dispatched. 2475: # $id - Tail of the command, contain the id of the resource 2476: # we want to fetch. 2477: # $client - socket open on the client. 2478: # Return: 2479: # 1 - Inidcating processing can continue. 2480: # Side effects: 2481: # A reply is sent to the client. 2482: 2483: # 2484: sub TmpGetHandler { 2485: my $cmd = shift; 2486: my $id = shift; 2487: my $client = shift; 2488: my $userinput = "$cmd:$id"; 2489: 2490: chomp($id); 2491: $id=~s/\W/\_/g; 2492: my $store; 2493: my $execdir=$perlvar{'lonDaemons'}; 2494: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { 2495: my $reply=<$store>; 2496: Reply( $client, "$reply\n", $userinput); 2497: close $store; 2498: } else { 2499: Failure( $client, "error: ".($!+0)."IO::File->new Failed ". 2500: "while attempting tmpget\n", $userinput); 2501: } 2502: 2503: return 1; 2504: } 2505: RegisterHandler("tmpget", \&TmpGetHandler, 0, 1, 0); 2506: # 2507: # Process the tmpdel command. This command deletes a temp resource 2508: # created by the tmpput command. 2509: # 2510: # Parameters: 2511: # $cmd - Command that got us here. 2512: # $id - Id of the temporary resource created. 2513: # $client - socket open on the client process. 2514: # 2515: # Returns: 2516: # 1 - Indicating processing should continue. 2517: # Side Effects: 2518: # A file is deleted 2519: # A reply is sent to the client. 2520: sub TmpDelHandler { 2521: my $cmd = shift; 2522: my $id = shift; 2523: my $client = shift; 2524: 2525: my $userinput= "$cmd:$id"; 2526: 2527: chomp($id); 2528: $id=~s/\W/\_/g; 2529: my $execdir=$perlvar{'lonDaemons'}; 2530: if (unlink("$execdir/tmp/$id.tmp")) { 2531: Reply($client, "ok\n", $userinput); 2532: } else { 2533: Failure( $client, "error: ".($!+0)."Unlink tmp Failed ". 2534: "while attempting tmpdel\n", $userinput); 2535: } 2536: 2537: return 1; 2538: 2539: } 2540: RegisterHandler("tmpdel", \&TmpDelHandler, 0, 1, 0); 2541: # 2542: # ls - list the contents of a directory. For each file in the 2543: # selected directory the filename followed by the full output of 2544: # the stat function is returned. The returned info for each 2545: # file are separated by ':'. The stat fields are separated by &'s. 2546: # Parameters: 2547: # $cmd - The command that dispatched us (ls). 2548: # $ulsdir - The directory path to list... I'm not sure what this 2549: # is relative as things like ls:. return e.g. 2550: # no_such_dir. 2551: # $client - Socket open on the client. 2552: # Returns: 2553: # 1 - indicating that the daemon should not disconnect. 2554: # Side Effects: 2555: # The reply is written to $client. 2556: # 2557: sub LsHandler { 2558: my $cmd = shift; 2559: my $ulsdir = shift; 2560: my $client = shift; 2561: 2562: my $userinput = "$cmd:$ulsdir"; 2563: 2564: my $ulsout=''; 2565: my $ulsfn; 2566: if (-e $ulsdir) { 2567: if(-d $ulsdir) { 2568: if (opendir(LSDIR,$ulsdir)) { 2569: while ($ulsfn=readdir(LSDIR)) { 2570: my @ulsstats=stat($ulsdir.'/'.$ulsfn); 2571: $ulsout.=$ulsfn.'&'. 2572: join('&',@ulsstats).':'; 2573: } 2574: closedir(LSDIR); 2575: } 2576: } else { 2577: my @ulsstats=stat($ulsdir); 2578: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; 2579: } 2580: } else { 2581: $ulsout='no_such_dir'; 2582: } 2583: if ($ulsout eq '') { $ulsout='empty'; } 2584: Reply($client, "$ulsout\n", $userinput); 2585: 2586: 2587: return 1; 2588: } 2589: RegisterHandler("ls", \&LsHandler, 0, 1, 0); 2590: 2591: 2592: # 2593: # Processes the setannounce command. This command 2594: # creates a file named announce.txt in the top directory of 2595: # the documentn root and sets its contents. The announce.txt file is 2596: # printed in its entirety at the LonCAPA login page. Note: 2597: # once the announcement.txt fileis created it cannot be deleted. 2598: # However, setting the contents of the file to empty removes the 2599: # announcement from the login page of loncapa so who cares. 2600: # 2601: # Parameters: 2602: # $cmd - The command that got us dispatched. 2603: # $announcement - The text of the announcement. 2604: # $client - Socket open on the client process. 2605: # Retunrns: 2606: # 1 - Indicating request processing should continue 2607: # Side Effects: 2608: # The file {DocRoot}/announcement.txt is created. 2609: # A reply is sent to $client. 2610: # 2611: sub SetAnnounceHandler { 2612: my $cmd = shift; 2613: my $announcement = shift; 2614: my $client = shift; 2615: 2616: my $userinput = "$cmd:$announcement"; 2617: 2618: chomp($announcement); 2619: $announcement=&unescape($announcement); 2620: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. 2621: '/announcement.txt')) { 2622: print $store $announcement; 2623: close $store; 2624: Reply($client, "ok\n", $userinput); 2625: } else { 2626: Failure($client, "error: ".($!+0)."\n", $userinput); 2627: } 2628: 2629: return 1; 2630: } 2631: RegisterHandler("setannounce", \&SetAnnounceHandler, 0, 1, 0); 2632: 2633: # 2634: # Return the version of the daemon. This can be used to determine 2635: # the compatibility of cross version installations or, alternatively to 2636: # simply know who's out of date and who isn't. Note that the version 2637: # is returned concatenated with the tail. 2638: # Parameters: 2639: # $cmd - the request that dispatched to us. 2640: # $tail - Tail of the request (client's version?). 2641: # $client - Socket open on the client. 2642: #Returns: 2643: # 1 - continue processing requests. 2644: # Side Effects: 2645: # Replies with version to $client. 2646: sub GetVersionHandler { 2647: my $client = shift; 2648: my $tail = shift; 2649: my $client = shift; 2650: my $userinput = $client; 2651: 2652: Reply($client, &version($userinput)."\n", $userinput); 2653: 2654: 2655: return 1; 2656: } 2657: RegisterHandler("version", \&GetVersionHandler, 0, 1, 0); 2658: 2659: # Set the current host and domain. This is used to support 2660: # multihomed systems. Each IP of the system, or even separate daemons 2661: # on the same IP can be treated as handling a separate lonCAPA virtual 2662: # machine. This command selects the virtual lonCAPA. The client always 2663: # knows the right one since it is lonc and it is selecting the domain/system 2664: # from the hosts.tab file. 2665: # Parameters: 2666: # $cmd - Command that dispatched us. 2667: # $tail - Tail of the command (domain/host requested). 2668: # $socket - Socket open on the client. 2669: # 2670: # Returns: 2671: # 1 - Indicates the program should continue to process requests. 2672: # Side-effects: 2673: # The default domain/system context is modified for this daemon. 2674: # a reply is sent to the client. 2675: # 2676: sub SelectHostHandler { 2677: my $cmd = shift; 2678: my $tail = shift; 2679: my $socket = shift; 2680: 2681: my $userinput ="$cmd:$tail"; 2682: 2683: Reply($client, &sethost($userinput)."\n", $userinput); 2684: 2685: 2686: return 1; 2687: } 2688: RegisterHandler("sethost", \&SelectHostHandler, 0, 1, 0); 2689: 2690: # Process a request to exit: 2691: # - "bye" is sent to the client. 2692: # - The client socket is shutdown and closed. 2693: # - We indicate to the caller that we should exit. 2694: # Formal Parameters: 2695: # $cmd - The command that got us here. 2696: # $tail - Tail of the command (empty). 2697: # $client - Socket open on the tail. 2698: # Returns: 2699: # 0 - Indicating the program should exit!! 2700: # 2701: sub ExitHandler { 2702: my $cmd = shift; 2703: my $tail = shift; 2704: my $client = shift; 2705: 2706: my $userinput = "$cmd:$tail"; 2707: 2708: &logthis("Client $clientip ($clientname) hanging up: $userinput"); 2709: Reply($client, "bye\n", $userinput); 2710: $client->shutdown(2); # shutdown the socket forcibly. 2711: $client->close(); 2712: 2713: return 0; 2714: } 2715: RegisterHandler("exit", \&ExitHandler, 0, 1,1); 2716: RegisterHandler("init", \&ExitHandler, 0, 1,1); # RE-init is like exit. 2717: RegisterHandler("quit", \&ExitHandler, 0, 1,1); # I like this too! 2718: #------------------------------------------------------------------------------------ 2719: # 2720: # Process a Request. Takes a request from the client validates 2721: # it and performs the operation requested by it. Returns 2722: # a response to the client. 2723: # 2724: # Parameters: 2725: # request - A string containing the user's request. 2726: # Returns: 2727: # 0 - Requested to exit, caller should shut down. 2728: # 1 - Accept additional requests from the client. 2729: # 2730: sub ProcessRequest { 2731: my $Request = shift; 2732: my $KeepGoing = 1; # Assume we're not asked to stop. 2733: 2734: my $wasenc=0; 2735: my $userinput = $Request; # for compatibility with oldcode <yeach> 2736: 2737: 2738: # ------------------------------------------------------------ See if encrypted 2739: 2740: if($userinput =~ /^enc/) { 2741: $wasenc = 1; 2742: $userinput = Decipher($userinput); 2743: if(! $userinput) { 2744: Failure($client,"error:Encrypted data without negotiating key"); 2745: return 0; # Break off with this imposter. 2746: } 2747: } 2748: # Split off the request keyword from the rest of the stuff. 2749: 2750: my ($command, $tail) = split(/:/, $userinput, 2); 2751: 2752: Debug("Command received: $command, encoded = $wasenc"); 2753: 2754: 2755: # ------------------------------------------------------------- Normal commands 2756: 2757: # 2758: # If the command is in the hash, then execute it via the hash dispatch: 2759: # 2760: if(defined $Dispatcher{$command}) { 2761: 2762: my $DispatchInfo = $Dispatcher{$command}; 2763: my $Handler = $$DispatchInfo[0]; 2764: my $NeedEncode = $$DispatchInfo[1]; 2765: my $ClientTypes = $$DispatchInfo[2]; 2766: Debug("Matched dispatch hash: mustencode: $NeedEncode ClientType $ClientTypes"); 2767: 2768: # Validate the request: 2769: 2770: my $ok = 1; 2771: my $requesterprivs = 0; 2772: if(isClient()) { 2773: $requesterprivs |= $CLIENT_OK; 2774: } 2775: if(isManager()) { 2776: $requesterprivs |= $MANAGER_OK; 2777: } 2778: if($NeedEncode && (!$wasenc)) { 2779: Debug("Must encode but wasn't: $NeedEncode $wasenc"); 2780: $ok = 0; 2781: } 2782: if(($ClientTypes & $requesterprivs) == 0) { 2783: Debug("Client not privileged to do this operation"); 2784: $ok = 0; 2785: } 2786: 2787: if($ok) { 2788: Debug("Dispatching to handler $command $tail"); 2789: $KeepGoing = &$Handler($command, $tail, $client); 2790: } else { 2791: Debug("Refusing to dispatch because ok is false"); 2792: Failure($client, "refused", $userinput); 2793: } 2794: 2795: 2796: # ------------------------------------------------------------- unknown command 2797: 2798: } else { 2799: # unknown command 2800: Failure($client, "unknown_cmd\n", $userinput); 2801: } 2802: 2803: return $KeepGoing; 2804: } 2805: 2806: 2807: # 2808: # GetCertificate: Given a transaction that requires a certificate, 2809: # this function will extract the certificate from the transaction 2810: # request. Note that at this point, the only concept of a certificate 2811: # is the hostname to which we are connected. 2812: # 2813: # Parameter: 2814: # request - The request sent by our client (this parameterization may 2815: # need to change when we really use a certificate granting 2816: # authority. 2817: # 2818: sub GetCertificate { 2819: my $request = shift; 2820: 2821: return $clientip; 2822: } 2823: 2824: 2825: 2826: # 2827: # ReadManagerTable: Reads in the current manager table. For now this is 2828: # done on each manager authentication because: 2829: # - These authentications are not frequent 2830: # - This allows dynamic changes to the manager table 2831: # without the need to signal to the lond. 2832: # 2833: 2834: sub ReadManagerTable { 2835: 2836: # Clean out the old table first.. 2837: 2838: foreach my $key (keys %managers) { 2839: delete $managers{$key}; 2840: } 2841: 2842: my $tablename = $perlvar{'lonTabDir'}."/managers.tab"; 2843: if (!open (MANAGERS, $tablename)) { 2844: logthis('No manager table. Nobody can manage!!'); 2845: return; 2846: } 2847: while(my $host = <MANAGERS>) { 2848: chomp($host); 2849: if ($host =~ "^#") { # Comment line. 2850: logthis(' Skipping line: '. "$host\n"); 2851: next; 2852: } 2853: if (!defined $hostip{$host}) { # This is a non cluster member 2854: # The entry is of the form: 2855: # cluname:hostname 2856: # cluname - A 'cluster hostname' is needed in order to negotiate 2857: # the host key. 2858: # hostname- The dns name of the host. 2859: # 2860: my($cluname, $dnsname) = split(/:/, $host); 2861: 2862: my $ip = gethostbyname($dnsname); 2863: if(defined($ip)) { # bad names don't deserve entry. 2864: my $hostip = inet_ntoa($ip); 2865: $managers{$hostip} = $cluname; 2866: logthis(' registering manager '. 2867: "$dnsname as $cluname with $hostip \n"); 2868: } 2869: } else { 2870: logthis(' existing host'." $host\n"); 2871: $managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber 2872: } 2873: } 2874: } 2875: 2876: # 2877: # ValidManager: Determines if a given certificate represents a valid manager. 2878: # in this primitive implementation, the 'certificate' is 2879: # just the connecting loncapa client name. This is checked 2880: # against a valid client list in the configuration. 2881: # 2882: # 2883: sub ValidManager { 2884: my $certificate = shift; 2885: 2886: return isManager; 2887: } 2888: # 2889: # CopyFile: Called as part of the process of installing a 2890: # new configuration file. This function copies an existing 2891: # file to a backup file. 2892: # Parameters: 2893: # oldfile - Name of the file to backup. 2894: # newfile - Name of the backup file. 2895: # Return: 2896: # 0 - Failure (errno has failure reason). 2897: # 1 - Success. 2898: # 2899: sub CopyFile { 2900: my $oldfile = shift; 2901: my $newfile = shift; 2902: 2903: # The file must exist: 2904: 2905: if(-e $oldfile) { 2906: 2907: # Read the old file. 2908: 2909: my $oldfh = IO::File->new("< $oldfile"); 2910: if(!$oldfh) { 2911: return 0; 2912: } 2913: my @contents = <$oldfh>; # Suck in the entire file. 2914: 2915: # write the backup file: 2916: 2917: my $newfh = IO::File->new("> $newfile"); 2918: if(!(defined $newfh)){ 2919: return 0; 2920: } 2921: my $lines = scalar @contents; 2922: for (my $i =0; $i < $lines; $i++) { 2923: print $newfh ($contents[$i]); 2924: } 2925: 2926: $oldfh->close; 2927: $newfh->close; 2928: 2929: chmod(0660, $newfile); 2930: 2931: return 1; 2932: 2933: } else { 2934: return 0; 2935: } 2936: } 2937: # 2938: # Host files are passed out with externally visible host IPs. 2939: # If, for example, we are behind a fire-wall or NAT host, our 2940: # internally visible IP may be different than the externally 2941: # visible IP. Therefore, we always adjust the contents of the 2942: # host file so that the entry for ME is the IP that we believe 2943: # we have. At present, this is defined as the entry that 2944: # DNS has for us. If by some chance we are not able to get a 2945: # DNS translation for us, then we assume that the host.tab file 2946: # is correct. 2947: # BUGBUGBUG - in the future, we really should see if we can 2948: # easily query the interface(s) instead. 2949: # Parameter(s): 2950: # contents - The contents of the host.tab to check. 2951: # Returns: 2952: # newcontents - The adjusted contents. 2953: # 2954: # 2955: sub AdjustHostContents { 2956: my $contents = shift; 2957: my $adjusted; 2958: my $me = $perlvar{'lonHostID'}; 2959: 2960: foreach my $line (split(/\n/,$contents)) { 2961: if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { 2962: chomp($line); 2963: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); 2964: if ($id eq $me) { 2965: my $ip = gethostbyname($name); 2966: my $ipnew = inet_ntoa($ip); 2967: $ip = $ipnew; 2968: # Reconstruct the host line and append to adjusted: 2969: 2970: my $newline = "$id:$domain:$role:$name:$ip"; 2971: if($maxcon ne "") { # Not all hosts have loncnew tuning params 2972: $newline .= ":$maxcon:$idleto:$mincon"; 2973: } 2974: $adjusted .= $newline."\n"; 2975: 2976: } else { # Not me, pass unmodified. 2977: $adjusted .= $line."\n"; 2978: } 2979: } else { # Blank or comment never re-written. 2980: $adjusted .= $line."\n"; # Pass blanks and comments as is. 2981: } 2982: } 2983: return $adjusted; 2984: } 2985: # 2986: # InstallFile: Called to install an administrative file: 2987: # - The file is created with <name>.tmp 2988: # - The <name>.tmp file is then mv'd to <name> 2989: # This lugubrious procedure is done to ensure that we are never without 2990: # a valid, even if dated, version of the file regardless of who crashes 2991: # and when the crash occurs. 2992: # 2993: # Parameters: 2994: # Name of the file 2995: # File Contents. 2996: # Return: 2997: # nonzero - success. 2998: # 0 - failure and $! has an errno. 2999: # 3000: sub InstallFile { 3001: my $Filename = shift; 3002: my $Contents = shift; 3003: my $TempFile = $Filename.".tmp"; 3004: 3005: # Open the file for write: 3006: 3007: my $fh = IO::File->new("> $TempFile"); # Write to temp. 3008: if(!(defined $fh)) { 3009: &logthis(' Unable to create '.$TempFile.""); 3010: return 0; 3011: } 3012: # write the contents of the file: 3013: 3014: print $fh ($Contents); 3015: $fh->close; # In case we ever have a filesystem w. locking 3016: 3017: chmod(0660, $TempFile); 3018: 3019: # Now we can move install the file in position. 3020: 3021: move($TempFile, $Filename); 3022: 3023: return 1; 3024: } 3025: # 3026: # ConfigFileFromSelector: converts a configuration file selector 3027: # (one of host or domain at this point) into a 3028: # configuration file pathname. 3029: # 3030: # Parameters: 3031: # selector - Configuration file selector. 3032: # Returns: 3033: # Full path to the file or undef if the selector is invalid. 3034: # 3035: sub ConfigFileFromSelector { 3036: my $selector = shift; 3037: my $tablefile; 3038: 3039: my $tabledir = $perlvar{'lonTabDir'}.'/'; 3040: if ($selector eq "hosts") { 3041: $tablefile = $tabledir."hosts.tab"; 3042: } elsif ($selector eq "domain") { 3043: $tablefile = $tabledir."domain.tab"; 3044: } else { 3045: return undef; 3046: } 3047: return $tablefile; 3048: 3049: } 3050: # 3051: # PushFile: Called to do an administrative push of a file. 3052: # - Ensure the file being pushed is one we support. 3053: # - Backup the old file to <filename.saved> 3054: # - Separate the contents of the new file out from the 3055: # rest of the request. 3056: # - Write the new file. 3057: # Parameter: 3058: # Request - The entire user request. This consists of a : separated 3059: # string pushfile:tablename:contents. 3060: # NOTE: The contents may have :'s in it as well making things a bit 3061: # more interesting... but not much. 3062: # Returns: 3063: # String to send to client ("ok" or "refused" if bad file). 3064: # 3065: sub PushFile { 3066: my $request = shift; 3067: my ($command, $filename, $contents) = split(":", $request, 3); 3068: 3069: # At this point in time, pushes for only the following tables are 3070: # supported: 3071: # hosts.tab ($filename eq host). 3072: # domain.tab ($filename eq domain). 3073: # Construct the destination filename or reject the request. 3074: # 3075: # lonManage is supposed to ensure this, however this session could be 3076: # part of some elaborate spoof that managed somehow to authenticate. 3077: # 3078: 3079: 3080: my $tablefile = ConfigFileFromSelector($filename); 3081: if(! (defined $tablefile)) { 3082: return "refused"; 3083: } 3084: # 3085: # >copy< the old table to the backup table 3086: # don't rename in case system crashes/reboots etc. in the time 3087: # window between a rename and write. 3088: # 3089: my $backupfile = $tablefile; 3090: $backupfile =~ s/\.tab$/.old/; 3091: if(!CopyFile($tablefile, $backupfile)) { 3092: &logthis(' CopyFile from '.$tablefile." to ".$backupfile." failed "); 3093: return "error:$!"; 3094: } 3095: &logthis(' Pushfile: backed up ' 3096: .$tablefile." to $backupfile"); 3097: 3098: # If the file being pushed is the host file, we adjust the entry for ourself so that the 3099: # IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible 3100: # to conceive of conditions where we don't have a DNS entry locally. This is possible in a 3101: # network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now) 3102: # that possibilty. 3103: 3104: if($filename eq "host") { 3105: $contents = AdjustHostContents($contents); 3106: } 3107: 3108: # Install the new file: 3109: 3110: if(!InstallFile($tablefile, $contents)) { 3111: &logthis(' Pushfile: unable to install ' 3112: .$tablefile." $! "); 3113: return "error:$!"; 3114: } else { 3115: &logthis(' Installed new '.$tablefile 3116: .""); 3117: 3118: } 3119: 3120: 3121: # Indicate success: 3122: 3123: return "ok"; 3124: 3125: } 3126: 3127: # 3128: # Called to re-init either lonc or lond. 3129: # 3130: # Parameters: 3131: # request - The full request by the client. This is of the form 3132: # reinit:<process> 3133: # where <process> is allowed to be either of 3134: # lonc or lond 3135: # 3136: # Returns: 3137: # The string to be sent back to the client either: 3138: # ok - Everything worked just fine. 3139: # error:why - There was a failure and why describes the reason. 3140: # 3141: # 3142: sub ReinitProcess { 3143: my $request = shift; 3144: 3145: 3146: # separate the request (reinit) from the process identifier and 3147: # validate it producing the name of the .pid file for the process. 3148: # 3149: # 3150: my ($junk, $process) = split(":", $request); 3151: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/'; 3152: if($process eq 'lonc') { 3153: $processpidfile = $processpidfile."lonc.pid"; 3154: if (!open(PIDFILE, "< $processpidfile")) { 3155: return "error:Open failed for $processpidfile"; 3156: } 3157: my $loncpid = <PIDFILE>; 3158: close(PIDFILE); 3159: logthis(' Reinitializing lonc pid='.$loncpid 3160: .""); 3161: kill("USR2", $loncpid); 3162: } elsif ($process eq 'lond') { 3163: logthis(' Reinitializing self (lond) '); 3164: &UpdateHosts; # Lond is us!! 3165: } else { 3166: &logthis('"); 3168: return "error:Invalid process identifier $process"; 3169: } 3170: return 'ok'; 3171: } 3172: # Validate a line in a configuration file edit script: 3173: # Validation includes: 3174: # - Ensuring the command is valid. 3175: # - Ensuring the command has sufficient parameters 3176: # Parameters: 3177: # scriptline - A line to validate (\n has been stripped for what it's worth). 3178: # 3179: # Return: 3180: # 0 - Invalid scriptline. 3181: # 1 - Valid scriptline 3182: # NOTE: 3183: # Only the command syntax is checked, not the executability of the 3184: # command. 3185: # 3186: sub isValidEditCommand { 3187: my $scriptline = shift; 3188: 3189: # Line elements are pipe separated: 3190: 3191: my ($command, $key, $newline) = split(/\|/, $scriptline); 3192: &logthis(' isValideditCommand checking: '. 3193: "Command = '$command', Key = '$key', Newline = '$newline' \n"); 3194: 3195: if ($command eq "delete") { 3196: # 3197: # key with no newline. 3198: # 3199: if( ($key eq "") || ($newline ne "")) { 3200: return 0; # Must have key but no newline. 3201: } else { 3202: return 1; # Valid syntax. 3203: } 3204: } elsif ($command eq "replace") { 3205: # 3206: # key and newline: 3207: # 3208: if (($key eq "") || ($newline eq "")) { 3209: return 0; 3210: } else { 3211: return 1; 3212: } 3213: } elsif ($command eq "append") { 3214: if (($key ne "") && ($newline eq "")) { 3215: return 1; 3216: } else { 3217: return 0; 3218: } 3219: } else { 3220: return 0; # Invalid command. 3221: } 3222: return 0; # Should not get here!!! 3223: } 3224: # 3225: # ApplyEdit - Applies an edit command to a line in a configuration 3226: # file. It is the caller's responsiblity to validate the 3227: # edit line. 3228: # Parameters: 3229: # $directive - A single edit directive to apply. 3230: # Edit directives are of the form: 3231: # append|newline - Appends a new line to the file. 3232: # replace|key|newline - Replaces the line with key value 'key' 3233: # delete|key - Deletes the line with key value 'key'. 3234: # $editor - A config file editor object that contains the 3235: # file being edited. 3236: # 3237: sub ApplyEdit { 3238: my $directive = shift; 3239: my $editor = shift; 3240: 3241: # Break the directive down into its command and its parameters 3242: # (at most two at this point. The meaning of the parameters, if in fact 3243: # they exist depends on the command). 3244: 3245: my ($command, $p1, $p2) = split(/\|/, $directive); 3246: 3247: if($command eq "append") { 3248: $editor->Append($p1); # p1 - key p2 null. 3249: } elsif ($command eq "replace") { 3250: $editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline. 3251: } elsif ($command eq "delete") { 3252: $editor->DeleteLine($p1); # p1 - key p2 null. 3253: } else { # Should not get here!!! 3254: die "Invalid command given to ApplyEdit $command"; 3255: } 3256: } 3257: # 3258: # AdjustOurHost: 3259: # Adjusts a host file stored in a configuration file editor object 3260: # for the true IP address of this host. This is necessary for hosts 3261: # that live behind a firewall. 3262: # Those hosts have a publicly distributed IP of the firewall, but 3263: # internally must use their actual IP. We assume that a given 3264: # host only has a single IP interface for now. 3265: # Formal Parameters: 3266: # editor - The configuration file editor to adjust. This 3267: # editor is assumed to contain a hosts.tab file. 3268: # Strategy: 3269: # - Figure out our hostname. 3270: # - Lookup the entry for this host. 3271: # - Modify the line to contain our IP 3272: # - Do a replace for this host. 3273: sub AdjustOurHost { 3274: my $editor = shift; 3275: 3276: # figure out who I am. 3277: 3278: my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname. 3279: 3280: # Get my host file entry. 3281: 3282: my $ConfigLine = $editor->Find($myHostName); 3283: if(! (defined $ConfigLine)) { 3284: die "AdjustOurHost - no entry for me in hosts file $myHostName"; 3285: } 3286: # figure out my IP: 3287: # Use the config line to get my hostname. 3288: # Use gethostbyname to translate that into an IP address. 3289: # 3290: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine); 3291: my $BinaryIp = gethostbyname($name); 3292: my $ip = inet_ntoa($ip); 3293: # 3294: # Reassemble the config line from the elements in the list. 3295: # Note that if the loncnew items were not present before, they will 3296: # be now even if they would be empty 3297: # 3298: my $newConfigLine = $id; 3299: foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) { 3300: $newConfigLine .= ":".$item; 3301: } 3302: # Replace the line: 3303: 3304: $editor->ReplaceLine($id, $newConfigLine); 3305: 3306: } 3307: # 3308: # ReplaceConfigFile: 3309: # Replaces a configuration file with the contents of a 3310: # configuration file editor object. 3311: # This is done by: 3312: # - Copying the target file to <filename>.old 3313: # - Writing the new file to <filename>.tmp 3314: # - Moving <filename.tmp> -> <filename> 3315: # This laborious process ensures that the system is never without 3316: # a configuration file that's at least valid (even if the contents 3317: # may be dated). 3318: # Parameters: 3319: # filename - Name of the file to modify... this is a full path. 3320: # editor - Editor containing the file. 3321: # 3322: sub ReplaceConfigFile { 3323: my $filename = shift; 3324: my $editor = shift; 3325: 3326: CopyFile ($filename, $filename.".old"); 3327: 3328: my $contents = $editor->Get(); # Get the contents of the file. 3329: 3330: InstallFile($filename, $contents); 3331: } 3332: # 3333: # 3334: # Called to edit a configuration table file 3335: # Parameters: 3336: # request - The entire command/request sent by lonc or lonManage 3337: # Return: 3338: # The reply to send to the client. 3339: # 3340: sub EditFile { 3341: my $request = shift; 3342: 3343: # Split the command into it's pieces: edit:filetype:script 3344: 3345: my ($request, $filetype, $script) = split(/:/, $request,3); # : in script 3346: 3347: # Check the pre-coditions for success: 3348: 3349: if($request != "edit") { # Something is amiss afoot alack. 3350: return "error:edit request detected, but request != 'edit'\n"; 3351: } 3352: if( ($filetype ne "hosts") && 3353: ($filetype ne "domain")) { 3354: return "error:edit requested with invalid file specifier: $filetype \n"; 3355: } 3356: 3357: # Split the edit script and check it's validity. 3358: 3359: my @scriptlines = split(/\n/, $script); # one line per element. 3360: my $linecount = scalar(@scriptlines); 3361: for(my $i = 0; $i < $linecount; $i++) { 3362: chomp($scriptlines[$i]); 3363: if(!isValidEditCommand($scriptlines[$i])) { 3364: return "error:edit with bad script line: '$scriptlines[$i]' \n"; 3365: } 3366: } 3367: 3368: # Execute the edit operation. 3369: # - Create a config file editor for the appropriate file and 3370: # - execute each command in the script: 3371: # 3372: my $configfile = ConfigFileFromSelector($filetype); 3373: if (!(defined $configfile)) { 3374: return "refused\n"; 3375: } 3376: my $editor = ConfigFileEdit->new($configfile); 3377: 3378: for (my $i = 0; $i < $linecount; $i++) { 3379: ApplyEdit($scriptlines[$i], $editor); 3380: } 3381: # If the file is the host file, ensure that our host is 3382: # adjusted to have our ip: 3383: # 3384: if($filetype eq "host") { 3385: AdjustOurHost($editor); 3386: } 3387: # Finally replace the current file with our file. 3388: # 3389: ReplaceConfigFile($configfile, $editor); 3390: 3391: return "ok\n"; 3392: } 3393: # 3394: # Convert an error return code from lcpasswd to a string value. 3395: # 3396: sub lcpasswdstrerror { 3397: my $ErrorCode = shift; 3398: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { 3399: return "lcpasswd Unrecognized error return value ".$ErrorCode; 3400: } else { 3401: return $passwderrors[$ErrorCode]; 3402: } 3403: } 3404: 3405: # 3406: # Convert an error return code from lcuseradd to a string value: 3407: # 3408: sub lcuseraddstrerror { 3409: my $ErrorCode = shift; 3410: if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) { 3411: return "lcuseradd - Unrecognized error code: ".$ErrorCode; 3412: } else { 3413: return $adderrors[$ErrorCode]; 3414: } 3415: } 3416: 3417: # grabs exception and records it to log before exiting 3418: sub catchexception { 3419: my ($error)=@_; 3420: $SIG{'QUIT'}='DEFAULT'; 3421: $SIG{__DIE__}='DEFAULT'; 3422: &status("Catching exception"); 3423: &logthis("CRITICAL: " 3424: ."ABNORMAL EXIT. Child $$ for server $thisserver died through " 3425: ."a crash with this error msg->[$error]"); 3426: &logthis('Famous last words: '.$status.' - '.$lastlog); 3427: if ($client) { print $client "error: $error\n"; } 3428: $server->close(); 3429: die($error); 3430: } 3431: 3432: sub timeout { 3433: &status("Handling Timeout"); 3434: &logthis("CRITICAL: TIME OUT ".$$.""); 3435: &catchexception('Timeout'); 3436: } 3437: # -------------------------------- Set signal handlers to record abnormal exits 3438: 3439: $SIG{'QUIT'}=\&catchexception; 3440: $SIG{__DIE__}=\&catchexception; 3441: 3442: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf 3443: &status("Read loncapa.conf and loncapa_apache.conf"); 3444: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); 3445: %perlvar=%{$perlvarref}; 3446: undef $perlvarref; 3447: 3448: # ----------------------------- Make sure this process is running from user=www 3449: my $wwwid=getpwnam('www'); 3450: if ($wwwid!=$<) { 3451: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 3452: my $subj="LON: $currenthostid User ID mismatch"; 3453: system("echo 'User ID mismatch. lond must be run as user www.' |\ 3454: mailto $emailto -s '$subj' > /dev/null"); 3455: exit 1; 3456: } 3457: 3458: # --------------------------------------------- Check if other instance running 3459: 3460: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; 3461: 3462: if (-e $pidfile) { 3463: my $lfh=IO::File->new("$pidfile"); 3464: my $pide=<$lfh>; 3465: chomp($pide); 3466: if (kill 0 => $pide) { die "already running"; } 3467: } 3468: 3469: # ------------------------------------------------------------- Read hosts file 3470: 3471: 3472: 3473: # establish SERVER socket, bind and listen. 3474: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'}, 3475: Type => SOCK_STREAM, 3476: Proto => 'tcp', 3477: Reuse => 1, 3478: Listen => 10 ) 3479: or die "making socket: $@\n"; 3480: 3481: # --------------------------------------------------------- Do global variables 3482: 3483: # global variables 3484: 3485: my %children = (); # keys are current child process IDs 3486: my $children = 0; # current number of children 3487: 3488: sub REAPER { # takes care of dead children 3489: $SIG{CHLD} = \&REAPER; 3490: &status("Handling child death"); 3491: my $pid = wait; 3492: if (defined($children{$pid})) { 3493: &logthis("Child $pid died"); 3494: $children --; 3495: delete $children{$pid}; 3496: } else { 3497: &logthis("Unknown Child $pid died"); 3498: } 3499: &status("Finished Handling child death"); 3500: } 3501: 3502: sub HUNTSMAN { # signal handler for SIGINT 3503: &status("Killing children (INT)"); 3504: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 3505: kill 'INT' => keys %children; 3506: &logthis("Free socket: ".shutdown($server,2)); # free up socket 3507: my $execdir=$perlvar{'lonDaemons'}; 3508: unlink("$execdir/logs/lond.pid"); 3509: &logthis("CRITICAL: Shutting down"); 3510: &status("Done killing children"); 3511: exit; # clean up with dignity 3512: } 3513: 3514: sub HUPSMAN { # signal handler for SIGHUP 3515: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 3516: &status("Killing children for restart (HUP)"); 3517: kill 'INT' => keys %children; 3518: &logthis("Free socket: ".shutdown($server,2)); # free up socket 3519: &logthis("CRITICAL: Restarting"); 3520: my $execdir=$perlvar{'lonDaemons'}; 3521: unlink("$execdir/logs/lond.pid"); 3522: &status("Restarting self (HUP)"); 3523: exec("$execdir/lond"); # here we go again 3524: } 3525: 3526: # 3527: # Kill off hashes that describe the host table prior to re-reading it. 3528: # Hashes affected are: 3529: # %hostid, %hostdom %hostip 3530: # 3531: sub KillHostHashes { 3532: foreach my $key (keys %hostid) { 3533: delete $hostid{$key}; 3534: } 3535: foreach my $key (keys %hostdom) { 3536: delete $hostdom{$key}; 3537: } 3538: foreach my $key (keys %hostip) { 3539: delete $hostip{$key}; 3540: } 3541: } 3542: # 3543: # Read in the host table from file and distribute it into the various hashes: 3544: # 3545: # - %hostid - Indexed by IP, the loncapa hostname. 3546: # - %hostdom - Indexed by loncapa hostname, the domain. 3547: # - %hostip - Indexed by hostid, the Ip address of the host. 3548: sub ReadHostTable { 3549: 3550: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; 3551: 3552: while (my $configline=<CONFIG>) { 3553: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); 3554: chomp($ip); $ip=~s/\D+$//; 3555: $hostid{$ip}=$id; 3556: $hostdom{$id}=$domain; 3557: $hostip{$id}=$ip; 3558: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } 3559: } 3560: close(CONFIG); 3561: } 3562: # 3563: # Reload the Apache daemon's state. 3564: # This is done by invoking /home/httpd/perl/apachereload 3565: # a setuid perl script that can be root for us to do this job. 3566: # 3567: sub ReloadApache { 3568: my $execdir = $perlvar{'lonDaemons'}; 3569: my $script = $execdir."/apachereload"; 3570: system($script); 3571: } 3572: 3573: # 3574: # Called in response to a USR2 signal. 3575: # - Reread hosts.tab 3576: # - All children connected to hosts that were removed from hosts.tab 3577: # are killed via SIGINT 3578: # - All children connected to previously existing hosts are sent SIGUSR1 3579: # - Our internal hosts hash is updated to reflect the new contents of 3580: # hosts.tab causing connections from hosts added to hosts.tab to 3581: # now be honored. 3582: # 3583: sub UpdateHosts { 3584: &status("Reload hosts.tab"); 3585: logthis(' Updating connections '); 3586: # 3587: # The %children hash has the set of IP's we currently have children 3588: # on. These need to be matched against records in the hosts.tab 3589: # Any ip's no longer in the table get killed off they correspond to 3590: # either dropped or changed hosts. Note that the re-read of the table 3591: # will take care of new and changed hosts as connections come into being. 3592: 3593: 3594: KillHostHashes; 3595: ReadHostTable; 3596: 3597: foreach my $child (keys %children) { 3598: my $childip = $children{$child}; 3599: if(!$hostid{$childip}) { 3600: logthis(' UpdateHosts killing child ' 3601: ." $child for ip $childip "); 3602: kill('INT', $child); 3603: } else { 3604: logthis(' keeping child for ip ' 3605: ." $childip (pid=$child) "); 3606: } 3607: } 3608: ReloadApache; 3609: &status("Finished reloading hosts.tab"); 3610: } 3611: 3612: 3613: sub checkchildren { 3614: &status("Checking on the children (sending signals)"); 3615: &initnewstatus(); 3616: &logstatus(); 3617: &logthis('Going to check on the children'); 3618: my $docdir=$perlvar{'lonDocRoot'}; 3619: foreach (sort keys %children) { 3620: sleep 1; 3621: unless (kill 'USR1' => $_) { 3622: &logthis ('Child '.$_.' is dead'); 3623: &logstatus($$.' is dead'); 3624: } 3625: } 3626: sleep 5; 3627: $SIG{ALRM} = sub { die "timeout" }; 3628: $SIG{__DIE__} = 'DEFAULT'; 3629: &status("Checking on the children (waiting for reports)"); 3630: foreach (sort keys %children) { 3631: unless (-e "$docdir/lon-status/londchld/$_.txt") { 3632: eval { 3633: alarm(300); 3634: &logthis('Child '.$_.' did not respond'); 3635: kill 9 => $_; 3636: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 3637: #$subj="LON: $currenthostid killed lond process $_"; 3638: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; 3639: #$execdir=$perlvar{'lonDaemons'}; 3640: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; 3641: alarm(0); 3642: } 3643: } 3644: } 3645: $SIG{ALRM} = 'DEFAULT'; 3646: $SIG{__DIE__} = \&catchexception; 3647: &status("Finished checking children"); 3648: } 3649: 3650: # --------------------------------------------------------------------- Logging 3651: 3652: sub logthis { 3653: my $message=shift; 3654: my $execdir=$perlvar{'lonDaemons'}; 3655: my $fh=IO::File->new(">>$execdir/logs/lond.log"); 3656: my $now=time; 3657: my $local=localtime($now); 3658: $lastlog=$local.': '.$message; 3659: print $fh "$local ($$): $message\n"; 3660: } 3661: 3662: # ------------------------- Conditional log if $DEBUG true. 3663: sub Debug { 3664: my $message = shift; 3665: if($DEBUG) { 3666: &logthis($message); 3667: } 3668: } 3669: 3670: # 3671: # Sub to do replies to client.. this gives a hook for some 3672: # debug tracing too: 3673: # Parameters: 3674: # fd - File open on client. 3675: # reply - Text to send to client. 3676: # request - Original request from client. 3677: # 3678: # Note: This increments Transactions 3679: # 3680: sub Reply { 3681: alarm(120); 3682: my $fd = shift; 3683: my $reply = shift; 3684: my $request = shift; 3685: 3686: print $fd $reply; 3687: Debug("Request was $request Reply was $reply"); 3688: 3689: $Transactions++; 3690: alarm(0); 3691: 3692: 3693: } 3694: # 3695: # Sub to report a failure. 3696: # This function: 3697: # - Increments the failure statistic counters. 3698: # - Invokes Reply to send the error message to the client. 3699: # Parameters: 3700: # fd - File descriptor open on the client 3701: # reply - Reply text to emit. 3702: # request - The original request message (used by Reply 3703: # to debug if that's enabled. 3704: # Implicit outputs: 3705: # $Failures- The number of failures is incremented. 3706: # Reply (invoked here) sends a message to the 3707: # client: 3708: # 3709: sub Failure { 3710: my $fd = shift; 3711: my $reply = shift; 3712: my $request = shift; 3713: 3714: $Failures++; 3715: Reply($fd, $reply, $request); # That's simple eh? 3716: } 3717: # ------------------------------------------------------------------ Log status 3718: 3719: sub logstatus { 3720: &status("Doing logging"); 3721: my $docdir=$perlvar{'lonDocRoot'}; 3722: { 3723: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); 3724: print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; 3725: $fh->close(); 3726: } 3727: &status("Finished londstatus.txt"); 3728: { 3729: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); 3730: print $fh $status."\n".$lastlog."\n".time; 3731: $fh->close(); 3732: } 3733: ResetStatistics; 3734: &status("Finished logging"); 3735: 3736: } 3737: 3738: sub initnewstatus { 3739: my $docdir=$perlvar{'lonDocRoot'}; 3740: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); 3741: my $now=time; 3742: my $local=localtime($now); 3743: print $fh "LOND status $local - parent $$\n\n"; 3744: opendir(DIR,"$docdir/lon-status/londchld"); 3745: while (my $filename=readdir(DIR)) { 3746: unlink("$docdir/lon-status/londchld/$filename"); 3747: } 3748: closedir(DIR); 3749: } 3750: 3751: # -------------------------------------------------------------- Status setting 3752: 3753: sub status { 3754: my $what=shift; 3755: my $now=time; 3756: my $local=localtime($now); 3757: my $status = "lond: $what $local "; 3758: if($Transactions) { 3759: $status .= " Transactions: $Transactions Failed; $Failures"; 3760: } 3761: $0=$status; 3762: } 3763: 3764: # -------------------------------------------------------- Escape Special Chars 3765: 3766: sub escape { 3767: my $str=shift; 3768: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 3769: return $str; 3770: } 3771: 3772: # ----------------------------------------------------- Un-Escape Special Chars 3773: 3774: sub unescape { 3775: my $str=shift; 3776: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 3777: return $str; 3778: } 3779: 3780: # ----------------------------------------------------------- Send USR1 to lonc 3781: 3782: sub reconlonc { 3783: my $peerfile=shift; 3784: &logthis("Trying to reconnect for $peerfile"); 3785: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 3786: if (my $fh=IO::File->new("$loncfile")) { 3787: my $loncpid=<$fh>; 3788: chomp($loncpid); 3789: if (kill 0 => $loncpid) { 3790: &logthis("lonc at pid $loncpid responding, sending USR1"); 3791: kill USR1 => $loncpid; 3792: } else { 3793: &logthis("CRITICAL: " 3794: ."lonc at pid $loncpid not responding, giving up"); 3795: } 3796: } else { 3797: &logthis('CRITICAL: lonc not running, giving up'); 3798: } 3799: } 3800: 3801: # -------------------------------------------------- Non-critical communication 3802: 3803: sub subreply { 3804: my ($cmd,$server)=@_; 3805: my $peerfile="$perlvar{'lonSockDir'}/$server"; 3806: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 3807: Type => SOCK_STREAM, 3808: Timeout => 10) 3809: or return "con_lost"; 3810: print $sclient "$cmd\n"; 3811: my $answer=<$sclient>; 3812: chomp($answer); 3813: if (!$answer) { $answer="con_lost"; } 3814: return $answer; 3815: } 3816: 3817: sub reply { 3818: my ($cmd,$server)=@_; 3819: my $answer; 3820: if ($server ne $currenthostid) { 3821: $answer=subreply($cmd,$server); 3822: if ($answer eq 'con_lost') { 3823: $answer=subreply("ping",$server); 3824: if ($answer ne $server) { 3825: &logthis("sub reply: answer != server answer is $answer, server is $server"); 3826: &reconlonc("$perlvar{'lonSockDir'}/$server"); 3827: } 3828: $answer=subreply($cmd,$server); 3829: } 3830: } else { 3831: $answer='self_reply'; 3832: } 3833: return $answer; 3834: } 3835: 3836: # -------------------------------------------------------------- Talk to lonsql 3837: 3838: sub sqlreply { 3839: my ($cmd)=@_; 3840: my $answer=subsqlreply($cmd); 3841: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); } 3842: return $answer; 3843: } 3844: 3845: sub subsqlreply { 3846: my ($cmd)=@_; 3847: my $unixsock="mysqlsock"; 3848: my $peerfile="$perlvar{'lonSockDir'}/$unixsock"; 3849: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 3850: Type => SOCK_STREAM, 3851: Timeout => 10) 3852: or return "con_lost"; 3853: print $sclient "$cmd\n"; 3854: my $answer=<$sclient>; 3855: chomp($answer); 3856: if (!$answer) { $answer="con_lost"; } 3857: return $answer; 3858: } 3859: 3860: # -------------------------------------------- Return path to profile directory 3861: 3862: sub propath { 3863: my ($udom,$uname)=@_; 3864: $udom=~s/\W//g; 3865: $uname=~s/\W//g; 3866: my $subdir=$uname.'__'; 3867: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 3868: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 3869: return $proname; 3870: } 3871: 3872: # --------------------------------------- Is this the home server of an author? 3873: 3874: sub ishome { 3875: my $author=shift; 3876: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 3877: my ($udom,$uname)=split(/\//,$author); 3878: my $proname=propath($udom,$uname); 3879: if (-e $proname) { 3880: return 'owner'; 3881: } else { 3882: return 'not_owner'; 3883: } 3884: } 3885: 3886: # ======================================================= Continue main program 3887: # ---------------------------------------------------- Fork once and dissociate 3888: 3889: my $fpid=fork; 3890: exit if $fpid; 3891: die "Couldn't fork: $!" unless defined ($fpid); 3892: 3893: POSIX::setsid() or die "Can't start new session: $!"; 3894: 3895: # ------------------------------------------------------- Write our PID on disk 3896: 3897: my $execdir=$perlvar{'lonDaemons'}; 3898: open (PIDSAVE,">$execdir/logs/lond.pid"); 3899: print PIDSAVE "$$\n"; 3900: close(PIDSAVE); 3901: &logthis("CRITICAL: ---------- Starting ----------"); 3902: &status('Starting'); 3903: 3904: 3905: 3906: # ----------------------------------------------------- Install signal handlers 3907: 3908: 3909: $SIG{CHLD} = \&REAPER; 3910: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 3911: $SIG{HUP} = \&HUPSMAN; 3912: $SIG{USR1} = \&checkchildren; 3913: $SIG{USR2} = \&UpdateHosts; 3914: 3915: # Read the host hashes: 3916: 3917: ReadHostTable; 3918: 3919: 3920: # -------------------------------------------------------------- 3921: # Accept connections. When a connection comes in, it is validated 3922: # and if good, a child process is created to process transactions 3923: # along the connection. 3924: 3925: while (1) { 3926: &status('Starting accept'); 3927: $client = $server->accept() or next; 3928: &status('Accepted '.$client.' off to spawn'); 3929: make_new_child($client); 3930: &status('Finished spawning'); 3931: } 3932: 3933: sub make_new_child { 3934: my $pid; 3935: my $sigset; 3936: 3937: $client = shift; 3938: &status('Starting new child '.$client); 3939: &logthis(' Attempting to start child ('.$client. 3940: ")"); 3941: # block signal for fork 3942: $sigset = POSIX::SigSet->new(SIGINT); 3943: sigprocmask(SIG_BLOCK, $sigset) 3944: or die "Can't block SIGINT for fork: $!\n"; 3945: 3946: die "fork: $!" unless defined ($pid = fork); 3947: 3948: $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of 3949: # connection liveness. 3950: 3951: # 3952: # Figure out who we're talking to so we can record the peer in 3953: # the pid hash. 3954: # 3955: my $caller = getpeername($client); 3956: my ($port,$iaddr)=unpack_sockaddr_in($caller); 3957: $clientip=inet_ntoa($iaddr); 3958: 3959: if ($pid) { 3960: # Parent records the child's birth and returns. 3961: sigprocmask(SIG_UNBLOCK, $sigset) 3962: or die "Can't unblock SIGINT for fork: $!\n"; 3963: $children{$pid} = $clientip; 3964: $children++; 3965: &status('Started child '.$pid); 3966: return; 3967: } else { 3968: # Child can *not* return from this subroutine. 3969: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before 3970: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns 3971: #don't get intercepted 3972: $SIG{USR1}= \&logstatus; 3973: $SIG{ALRM}= \&timeout; 3974: $lastlog='Forked '; 3975: $status='Forked'; 3976: 3977: # unblock signals 3978: sigprocmask(SIG_UNBLOCK, $sigset) 3979: or die "Can't unblock SIGINT for fork: $!\n"; 3980: 3981: 3982: 3983: &Authen::Krb5::init_context(); 3984: &Authen::Krb5::init_ets(); 3985: 3986: &status('Accepted connection'); 3987: # ============================================================================= 3988: # do something with the connection 3989: # ----------------------------------------------------------------------------- 3990: # see if we know client and check for spoof IP by challenge 3991: 3992: ReadManagerTable; # May also be a manager!! 3993: 3994: my $clientrec=($hostid{$clientip} ne undef); 3995: my $ismanager=($managers{$clientip} ne undef); 3996: $clientname = "[unknonwn]"; 3997: if($clientrec) { # Establish client type. 3998: $ConnectionType = "client"; 3999: $clientname = $hostid{$clientip}; 4000: if($ismanager) { 4001: $ConnectionType = "both"; 4002: } 4003: } else { 4004: $ConnectionType = "manager"; 4005: $clientname = $managers{$clientip}; 4006: } 4007: my $clientok; 4008: if ($clientrec || $ismanager) { 4009: &status("Waiting for init from $clientip $clientname"); 4010: &logthis('INFO: Connection, '. 4011: $clientip. 4012: " ($clientname) connection type = $ConnectionType " ); 4013: &status("Connecting $clientip ($clientname))"); 4014: my $remotereq=<$client>; 4015: $remotereq=~s/[^\w:]//g; 4016: if ($remotereq =~ /^init/) { 4017: &sethost("sethost:$perlvar{'lonHostID'}"); 4018: my $challenge="$$".time; 4019: print $client "$challenge\n"; 4020: &status("Waiting for challenge reply from $clientip ($clientname)"); 4021: $remotereq=<$client>; 4022: $remotereq=~s/\W//g; 4023: if ($challenge eq $remotereq) { 4024: $clientok=1; 4025: print $client "ok\n"; 4026: } else { 4027: &logthis("WARNING: $clientip did not reply challenge"); 4028: &status('No challenge reply '.$clientip); 4029: } 4030: } else { 4031: &logthis("WARNING: " 4032: ."$clientip failed to initialize: >$remotereq< "); 4033: &status('No init '.$clientip); 4034: } 4035: } else { 4036: &logthis("WARNING: Unknown client $clientip"); 4037: &status('Hung up on '.$clientip); 4038: } 4039: if ($clientok) { 4040: # ---------------- New known client connecting, could mean machine online again 4041: 4042: foreach my $id (keys(%hostip)) { 4043: if ($hostip{$id} ne $clientip || 4044: $hostip{$currenthostid} eq $clientip) { 4045: # no need to try to do recon's to myself 4046: next; 4047: } 4048: &reconlonc("$perlvar{'lonSockDir'}/$id"); 4049: } 4050: &logthis("Established connection: $clientname"); 4051: &status('Will listen to '.$clientname); 4052: 4053: ResetStatistics(); 4054: 4055: # ------------------------------------------------------------ Process requests 4056: my $KeepGoing = 1; 4057: while ((my $userinput=GetRequest) && $KeepGoing) { 4058: $KeepGoing = ProcessRequest($userinput); 4059: # -------------------------------------------------------------------- complete 4060: 4061: &status('Listening to '.$clientname); 4062: } 4063: # --------------------------------------------- client unknown or fishy, refuse 4064: } else { 4065: print $client "refused\n"; 4066: $client->close(); 4067: &logthis("WARNING: " 4068: ."Rejected client $clientip, closing connection"); 4069: } 4070: } 4071: 4072: # ============================================================================= 4073: 4074: &logthis("CRITICAL: " 4075: ."Disconnect from $clientip ($clientname)"); 4076: 4077: 4078: # this exit is VERY important, otherwise the child will become 4079: # a producer of more and more children, forking yourself into 4080: # process death. 4081: exit; 4082: 4083: } 4084: 4085: 4086: # 4087: # Checks to see if the input roleput request was to set 4088: # an author role. If so, invokes the lchtmldir script to set 4089: # up a correct public_html 4090: # Parameters: 4091: # request - The request sent to the rolesput subchunk. 4092: # We're looking for /domain/_au 4093: # domain - The domain in which the user is having roles doctored. 4094: # user - Name of the user for which the role is being put. 4095: # authtype - The authentication type associated with the user. 4096: # 4097: sub ManagePermissions { 4098: my $request = shift; 4099: my $domain = shift; 4100: my $user = shift; 4101: my $authtype= shift; 4102: 4103: # See if the request is of the form /$domain/_au 4104: &logthis("ruequest is $request"); 4105: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... 4106: my $execdir = $perlvar{'lonDaemons'}; 4107: my $userhome= "/home/$user" ; 4108: &logthis("system $execdir/lchtmldir $userhome $user $authtype"); 4109: system("$execdir/lchtmldir $userhome $user $authtype"); 4110: } 4111: } 4112: # 4113: # GetAuthType - Determines the authorization type of a user in a domain. 4114: 4115: # Returns the authorization type or nouser if there is no such user. 4116: # 4117: sub GetAuthType { 4118: my $domain = shift; 4119: my $user = shift; 4120: 4121: Debug("GetAuthType( $domain, $user ) \n"); 4122: my $proname = &propath($domain, $user); 4123: my $passwdfile = "$proname/passwd"; 4124: if( -e $passwdfile ) { 4125: my $pf = IO::File->new($passwdfile); 4126: my $realpassword = <$pf>; 4127: chomp($realpassword); 4128: Debug("Password info = $realpassword\n"); 4129: my ($authtype, $contentpwd) = split(/:/, $realpassword); 4130: Debug("Authtype = $authtype, content = $contentpwd\n"); 4131: my $availinfo = ''; 4132: if($authtype eq 'krb4' or $authtype eq 'krb5') { 4133: $availinfo = $contentpwd; 4134: } 4135: 4136: return "$authtype:$availinfo"; 4137: } else { 4138: Debug("Returning nouser"); 4139: return "nouser"; 4140: } 4141: } 4142: 4143: sub addline { 4144: my ($fname,$hostid,$ip,$newline)=@_; 4145: my $contents; 4146: my $found=0; 4147: my $expr='^'.$hostid.':'.$ip.':'; 4148: $expr =~ s/\./\\\./g; 4149: my $sh; 4150: if ($sh=IO::File->new("$fname.subscription")) { 4151: while (my $subline=<$sh>) { 4152: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} 4153: } 4154: $sh->close(); 4155: } 4156: $sh=IO::File->new(">$fname.subscription"); 4157: if ($contents) { print $sh $contents; } 4158: if ($newline) { print $sh $newline; } 4159: $sh->close(); 4160: return $found; 4161: } 4162: 4163: sub getchat { 4164: my ($cdom,$cname,$udom,$uname)=@_; 4165: my %hash; 4166: my $proname=&propath($cdom,$cname); 4167: my @entries=(); 4168: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", 4169: &GDBM_READER(),0640)) { 4170: @entries=map { $_.':'.$hash{$_} } sort keys %hash; 4171: untie %hash; 4172: } 4173: my @participants=(); 4174: my $cutoff=time-60; 4175: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", 4176: &GDBM_WRCREAT(),0640)) { 4177: $hash{$uname.':'.$udom}=time; 4178: foreach (sort keys %hash) { 4179: if ($hash{$_}>$cutoff) { 4180: $participants[$#participants+1]='active_participant:'.$_; 4181: } 4182: } 4183: untie %hash; 4184: } 4185: return (@participants,@entries); 4186: } 4187: 4188: sub chatadd { 4189: my ($cdom,$cname,$newchat)=@_; 4190: my %hash; 4191: my $proname=&propath($cdom,$cname); 4192: my @entries=(); 4193: my $time=time; 4194: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", 4195: &GDBM_WRCREAT(),0640)) { 4196: @entries=map { $_.':'.$hash{$_} } sort keys %hash; 4197: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); 4198: my ($thentime,$idnum)=split(/\_/,$lastid); 4199: my $newid=$time.'_000000'; 4200: if ($thentime==$time) { 4201: $idnum=~s/^0+//; 4202: $idnum++; 4203: $idnum=substr('000000'.$idnum,-6,6); 4204: $newid=$time.'_'.$idnum; 4205: } 4206: $hash{$newid}=$newchat; 4207: my $expired=$time-3600; 4208: foreach (keys %hash) { 4209: my ($thistime)=($_=~/(\d+)\_/); 4210: if ($thistime<$expired) { 4211: delete $hash{$_}; 4212: } 4213: } 4214: untie %hash; 4215: } 4216: { 4217: my $hfh; 4218: if ($hfh=IO::File->new(">>$proname/chatroom.log")) { 4219: print $hfh "$time:".&unescape($newchat)."\n"; 4220: } 4221: } 4222: } 4223: 4224: sub unsub { 4225: my ($fname,$clientip)=@_; 4226: my $result; 4227: if (unlink("$fname.$clientname")) { 4228: $result="ok\n"; 4229: } else { 4230: $result="not_subscribed\n"; 4231: } 4232: if (-e "$fname.subscription") { 4233: my $found=&addline($fname,$clientname,$clientip,''); 4234: if ($found) { $result="ok\n"; } 4235: } else { 4236: if ($result != "ok\n") { $result="not_subscribed\n"; } 4237: } 4238: return $result; 4239: } 4240: 4241: sub currentversion { 4242: my $fname=shift; 4243: my $version=-1; 4244: my $ulsdir=''; 4245: if ($fname=~/^(.+)\/[^\/]+$/) { 4246: $ulsdir=$1; 4247: } 4248: my ($fnamere1,$fnamere2); 4249: # remove version if already specified 4250: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; 4251: # get the bits that go before and after the version number 4252: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { 4253: $fnamere1=$1; 4254: $fnamere2='.'.$2; 4255: } 4256: if (-e $fname) { $version=1; } 4257: if (-e $ulsdir) { 4258: if(-d $ulsdir) { 4259: if (opendir(LSDIR,$ulsdir)) { 4260: my $ulsfn; 4261: while ($ulsfn=readdir(LSDIR)) { 4262: # see if this is a regular file (ignore links produced earlier) 4263: my $thisfile=$ulsdir.'/'.$ulsfn; 4264: unless (-l $thisfile) { 4265: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) { 4266: if ($1>$version) { $version=$1; } 4267: } 4268: } 4269: } 4270: closedir(LSDIR); 4271: $version++; 4272: } 4273: } 4274: } 4275: return $version; 4276: } 4277: 4278: sub thisversion { 4279: my $fname=shift; 4280: my $version=-1; 4281: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { 4282: $version=$1; 4283: } 4284: return $version; 4285: } 4286: 4287: sub subscribe { 4288: my ($userinput,$clientip)=@_; 4289: my $result; 4290: my ($cmd,$fname)=split(/:/,$userinput); 4291: my $ownership=&ishome($fname); 4292: if ($ownership eq 'owner') { 4293: # explitly asking for the current version? 4294: unless (-e $fname) { 4295: my $currentversion=&currentversion($fname); 4296: if (&thisversion($fname)==$currentversion) { 4297: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { 4298: my $root=$1; 4299: my $extension=$2; 4300: symlink($root.'.'.$extension, 4301: $root.'.'.$currentversion.'.'.$extension); 4302: unless ($extension=~/\.meta$/) { 4303: symlink($root.'.'.$extension.'.meta', 4304: $root.'.'.$currentversion.'.'.$extension.'.meta'); 4305: } 4306: } 4307: } 4308: } 4309: if (-e $fname) { 4310: if (-d $fname) { 4311: $result="directory\n"; 4312: } else { 4313: if (-e "$fname.$clientname") {&unsub($fname,$clientip);} 4314: my $now=time; 4315: my $found=&addline($fname,$clientname,$clientip, 4316: "$clientname:$clientip:$now\n"); 4317: if ($found) { $result="$fname\n"; } 4318: # if they were subscribed to only meta data, delete that 4319: # subscription, when you subscribe to a file you also get 4320: # the metadata 4321: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } 4322: $fname=~s/\/home\/httpd\/html\/res/raw/; 4323: $fname="http://$thisserver/".$fname; 4324: $result="$fname\n"; 4325: } 4326: } else { 4327: $result="not_found\n"; 4328: } 4329: } else { 4330: $result="rejected\n"; 4331: } 4332: return $result; 4333: } 4334: 4335: sub make_passwd_file { 4336: my ($uname, $umode,$npass,$passfilename)=@_; 4337: my $result="ok\n"; 4338: if ($umode eq 'krb4' or $umode eq 'krb5') { 4339: { 4340: my $pf = IO::File->new(">$passfilename"); 4341: print $pf "$umode:$npass\n"; 4342: } 4343: } elsif ($umode eq 'internal') { 4344: my $salt=time; 4345: $salt=substr($salt,6,2); 4346: my $ncpass=crypt($npass,$salt); 4347: { 4348: &Debug("Creating internal auth"); 4349: my $pf = IO::File->new(">$passfilename"); 4350: print $pf "internal:$ncpass\n"; 4351: } 4352: } elsif ($umode eq 'localauth') { 4353: { 4354: my $pf = IO::File->new(">$passfilename"); 4355: print $pf "localauth:$npass\n"; 4356: } 4357: } elsif ($umode eq 'unix') { 4358: { 4359: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; 4360: { 4361: &Debug("Executing external: ".$execpath); 4362: &Debug("user = ".$uname.", Password =". $npass); 4363: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); 4364: print $se "$uname\n"; 4365: print $se "$npass\n"; 4366: print $se "$npass\n"; 4367: } 4368: my $useraddok = $?; 4369: if($useraddok > 0) { 4370: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); 4371: } 4372: my $pf = IO::File->new(">$passfilename"); 4373: print $pf "unix:\n"; 4374: } 4375: } elsif ($umode eq 'none') { 4376: { 4377: my $pf = IO::File->new(">$passfilename"); 4378: print $pf "none:\n"; 4379: } 4380: } else { 4381: $result="auth_mode_error\n"; 4382: } 4383: return $result; 4384: } 4385: 4386: sub sethost { 4387: my ($remotereq) = @_; 4388: my (undef,$hostid)=split(/:/,$remotereq); 4389: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } 4390: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { 4391: $currenthostid=$hostid; 4392: $currentdomainid=$hostdom{$hostid}; 4393: &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); 4394: } else { 4395: &logthis("Requested host id $hostid not an alias of ". 4396: $perlvar{'lonHostID'}." refusing connection"); 4397: return 'unable_to_set'; 4398: } 4399: return 'ok'; 4400: } 4401: 4402: sub version { 4403: my ($userinput)=@_; 4404: $remoteVERSION=(split(/:/,$userinput))[1]; 4405: return "version:$VERSION"; 4406: } 4407: ############## >>>>>>>>>>>>>>>>>>>>>>>>>> FUTUREWORK <<<<<<<<<<<<<<<<<<<<<<<<<<<< 4408: #There is a copy of this in lonnet.pm 4409: # Can we hoist these lil' things out into common places? 4410: # 4411: sub userload { 4412: my $numusers=0; 4413: { 4414: opendir(LONIDS,$perlvar{'lonIDsDir'}); 4415: my $filename; 4416: my $curtime=time; 4417: while ($filename=readdir(LONIDS)) { 4418: if ($filename eq '.' || $filename eq '..') {next;} 4419: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; 4420: if ($curtime-$mtime < 1800) { $numusers++; } 4421: } 4422: closedir(LONIDS); 4423: } 4424: my $userloadpercent=0; 4425: my $maxuserload=$perlvar{'lonUserLoadLim'}; 4426: if ($maxuserload) { 4427: $userloadpercent=100*$numusers/$maxuserload; 4428: } 4429: $userloadpercent=sprintf("%.2f",$userloadpercent); 4430: return $userloadpercent; 4431: } 4432: 4433: # ----------------------------------- POD (plain old documentation, CPAN style) 4434: 4435: =head1 NAME 4436: 4437: lond - "LON Daemon" Server (port "LOND" 5663) 4438: 4439: =head1 SYNOPSIS 4440: 4441: Usage: B<lond> 4442: 4443: Should only be run as user=www. This is a command-line script which 4444: is invoked by B<loncron>. There is no expectation that a typical user 4445: will manually start B<lond> from the command-line. (In other words, 4446: DO NOT START B<lond> YOURSELF.) 4447: 4448: =head1 DESCRIPTION 4449: 4450: There are two characteristics associated with the running of B<lond>, 4451: PROCESS MANAGEMENT (starting, stopping, handling child processes) 4452: and SERVER-SIDE ACTIVITIES (password authentication, user creation, 4453: subscriptions, etc). These are described in two large 4454: sections below. 4455: 4456: B<PROCESS MANAGEMENT> 4457: 4458: Preforker - server who forks first. Runs as a daemon. HUPs. 4459: Uses IDEA encryption 4460: 4461: B<lond> forks off children processes that correspond to the other servers 4462: in the network. Management of these processes can be done at the 4463: parent process level or the child process level. 4464: 4465: B<logs/lond.log> is the location of log messages. 4466: 4467: The process management is now explained in terms of linux shell commands, 4468: subroutines internal to this code, and signal assignments: 4469: 4470: =over 4 4471: 4472: =item * 4473: 4474: PID is stored in B<logs/lond.pid> 4475: 4476: This is the process id number of the parent B<lond> process. 4477: 4478: =item * 4479: 4480: SIGTERM and SIGINT 4481: 4482: Parent signal assignment: 4483: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 4484: 4485: Child signal assignment: 4486: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) 4487: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber 4488: to restart a new child.) 4489: 4490: Command-line invocations: 4491: B<kill> B<-s> SIGTERM I<PID> 4492: B<kill> B<-s> SIGINT I<PID> 4493: 4494: Subroutine B<HUNTSMAN>: 4495: This is only invoked for the B<lond> parent I<PID>. 4496: This kills all the children, and then the parent. 4497: The B<lonc.pid> file is cleared. 4498: 4499: =item * 4500: 4501: SIGHUP 4502: 4503: Current bug: 4504: This signal can only be processed the first time 4505: on the parent process. Subsequent SIGHUP signals 4506: have no effect. 4507: 4508: Parent signal assignment: 4509: $SIG{HUP} = \&HUPSMAN; 4510: 4511: Child signal assignment: 4512: none (nothing happens) 4513: 4514: Command-line invocations: 4515: B<kill> B<-s> SIGHUP I<PID> 4516: 4517: Subroutine B<HUPSMAN>: 4518: This is only invoked for the B<lond> parent I<PID>, 4519: This kills all the children, and then the parent. 4520: The B<lond.pid> file is cleared. 4521: 4522: =item * 4523: 4524: SIGUSR1 4525: 4526: Parent signal assignment: 4527: $SIG{USR1} = \&USRMAN; 4528: 4529: Child signal assignment: 4530: $SIG{USR1}= \&logstatus; 4531: 4532: Command-line invocations: 4533: B<kill> B<-s> SIGUSR1 I<PID> 4534: 4535: Subroutine B<USRMAN>: 4536: When invoked for the B<lond> parent I<PID>, 4537: SIGUSR1 is sent to all the children, and the status of 4538: each connection is logged. 4539: 4540: =item * 4541: 4542: SIGUSR2 4543: 4544: Parent Signal assignment: 4545: $SIG{USR2} = \&UpdateHosts 4546: 4547: Child signal assignment: 4548: NONE 4549: 4550: 4551: =item * 4552: 4553: SIGCHLD 4554: 4555: Parent signal assignment: 4556: $SIG{CHLD} = \&REAPER; 4557: 4558: Child signal assignment: 4559: none 4560: 4561: Command-line invocations: 4562: B<kill> B<-s> SIGCHLD I<PID> 4563: 4564: Subroutine B<REAPER>: 4565: This is only invoked for the B<lond> parent I<PID>. 4566: Information pertaining to the child is removed. 4567: The socket port is cleaned up. 4568: 4569: =back 4570: 4571: B<SERVER-SIDE ACTIVITIES> 4572: 4573: Server-side information can be accepted in an encrypted or non-encrypted 4574: method. 4575: 4576: =over 4 4577: 4578: =item ping 4579: 4580: Query a client in the hosts.tab table; "Are you there?" 4581: 4582: =item pong 4583: 4584: Respond to a ping query. 4585: 4586: =item ekey 4587: 4588: Read in encrypted key, make cipher. Respond with a buildkey. 4589: 4590: =item load 4591: 4592: Respond with CPU load based on a computation upon /proc/loadavg. 4593: 4594: =item currentauth 4595: 4596: Reply with current authentication information (only over an 4597: encrypted channel). 4598: 4599: =item auth 4600: 4601: Only over an encrypted channel, reply as to whether a user's 4602: authentication information can be validated. 4603: 4604: =item passwd 4605: 4606: Allow for a password to be set. 4607: 4608: =item makeuser 4609: 4610: Make a user. 4611: 4612: =item passwd 4613: 4614: Allow for authentication mechanism and password to be changed. 4615: 4616: =item home 4617: 4618: Respond to a question "are you the home for a given user?" 4619: 4620: =item update 4621: 4622: Update contents of a subscribed resource. 4623: 4624: =item unsubscribe 4625: 4626: The server is unsubscribing from a resource. 4627: 4628: =item subscribe 4629: 4630: The server is subscribing to a resource. 4631: 4632: =item log 4633: 4634: Place in B<logs/lond.log> 4635: 4636: =item put 4637: 4638: stores hash in namespace 4639: 4640: =item rolesput 4641: 4642: put a role into a user's environment 4643: 4644: =item get 4645: 4646: returns hash with keys from array 4647: reference filled in from namespace 4648: 4649: =item eget 4650: 4651: returns hash with keys from array 4652: reference filled in from namesp (encrypts the return communication) 4653: 4654: =item rolesget 4655: 4656: get a role from a user's environment 4657: 4658: =item del 4659: 4660: deletes keys out of array from namespace 4661: 4662: =item keys 4663: 4664: returns namespace keys 4665: 4666: =item dump 4667: 4668: dumps the complete (or key matching regexp) namespace into a hash 4669: 4670: =item store 4671: 4672: stores hash permanently 4673: for this url; hashref needs to be given and should be a \%hashname; the 4674: remaining args aren't required and if they aren't passed or are '' they will 4675: be derived from the ENV 4676: 4677: =item restore 4678: 4679: returns a hash for a given url 4680: 4681: =item querysend 4682: 4683: Tells client about the lonsql process that has been launched in response 4684: to a sent query. 4685: 4686: =item queryreply 4687: 4688: Accept information from lonsql and make appropriate storage in temporary 4689: file space. 4690: 4691: =item idput 4692: 4693: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers 4694: for each student, defined perhaps by the institutional Registrar.) 4695: 4696: =item idget 4697: 4698: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers 4699: for each student, defined perhaps by the institutional Registrar.) 4700: 4701: =item tmpput 4702: 4703: Accept and store information in temporary space. 4704: 4705: =item tmpget 4706: 4707: Send along temporarily stored information. 4708: 4709: =item ls 4710: 4711: List part of a user's directory. 4712: 4713: =item pushtable 4714: 4715: Pushes a file in /home/httpd/lonTab directory. Currently limited to: 4716: hosts.tab and domain.tab. The old file is copied to *.tab.backup but 4717: must be restored manually in case of a problem with the new table file. 4718: pushtable requires that the request be encrypted and validated via 4719: ValidateManager. The form of the command is: 4720: enc:pushtable tablename <tablecontents> \n 4721: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a 4722: cleartext newline. 4723: 4724: =item Hanging up (exit or init) 4725: 4726: What to do when a client tells the server that they (the client) 4727: are leaving the network. 4728: 4729: =item unknown command 4730: 4731: If B<lond> is sent an unknown command (not in the list above), 4732: it replys to the client "unknown_cmd". 4733: 4734: 4735: =item UNKNOWN CLIENT 4736: 4737: If the anti-spoofing algorithm cannot verify the client, 4738: the client is rejected (with a "refused" message sent 4739: to the client, and the connection is closed. 4740: 4741: =back 4742: 4743: =head1 PREREQUISITES 4744: 4745: IO::Socket 4746: IO::File 4747: Apache::File 4748: Symbol 4749: POSIX 4750: Crypt::IDEA 4751: LWP::UserAgent() 4752: GDBM_File 4753: Authen::Krb4 4754: Authen::Krb5 4755: 4756: =head1 COREQUISITES 4757: 4758: =head1 OSNAMES 4759: 4760: linux 4761: 4762: =head1 SCRIPT CATEGORIES 4763: 4764: Server/Process 4765: 4766: =cut