![]() ![]() | ![]() |
- prevent parent process from getting stuck
1: #!/usr/bin/perl 2: # The LearningOnline Network 3: # lond "LON Daemon" Server (port "LOND" 5663) 4: # 5: # $Id: lond,v 1.113 2003/03/13 21:01:52 albertel Exp $ 6: # 7: # Copyright Michigan State University Board of Trustees 8: # 9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 10: # 11: # LON-CAPA is free software; you can redistribute it and/or modify 12: # it under the terms of the GNU General Public License as published by 13: # the Free Software Foundation; either version 2 of the License, or 14: # (at your option) any later version. 15: # 16: # LON-CAPA is distributed in the hope that it will be useful, 17: # but WITHOUT ANY WARRANTY; without even the implied warranty of 18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19: # GNU General Public License for more details. 20: # 21: # You should have received a copy of the GNU General Public License 22: # along with LON-CAPA; if not, write to the Free Software 23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 24: # 25: # /home/httpd/html/adm/gpl.txt 26: # 27: # http://www.lon-capa.org/ 28: # 29: # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30, 30: # 7/8,7/9,7/10,7/12,7/17,7/19,9/21, 31: # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16, 32: # 12/7,12/15,01/06,01/11,01/12,01/14,2/8, 33: # 03/07,05/31 Gerd Kortemeyer 34: # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer 35: # 12/05,12/13,12/29 Gerd Kortemeyer 36: # YEAR=2001 37: # 02/12 Gerd Kortemeyer 38: # 03/24 Gerd Kortemeyer 39: # 05/11,05/28,08/30 Gerd Kortemeyer 40: # 11/26,11/27 Gerd Kortemeyer 41: # 12/22 Gerd Kortemeyer 42: # YEAR=2002 43: # 01/20/02,02/05 Gerd Kortemeyer 44: # 02/05 Guy Albertelli 45: # 02/12 Gerd Kortemeyer 46: # 02/19 Matthew Hall 47: # 02/25 Gerd Kortemeyer 48: # 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon 49: # logic simpler (and there were problems maintaining the preforked 50: # population). Since the time averaged connection rate is close to zero 51: # because lonc's purpose is to maintain near continuous connnections, 52: # preforking is not really needed. 53: ### 54: 55: 56: use lib '/home/httpd/lib/perl/'; 57: use LONCAPA::Configuration; 58: 59: use IO::Socket; 60: use IO::File; 61: use Apache::File; 62: use Symbol; 63: use POSIX; 64: use Crypt::IDEA; 65: use LWP::UserAgent(); 66: use GDBM_File; 67: use Authen::Krb4; 68: use Authen::Krb5; 69: use lib '/home/httpd/lib/perl/'; 70: use localauth; 71: 72: my $DEBUG = 0; # Non zero to enable debug log entries. 73: 74: my $status=''; 75: my $lastlog=''; 76: 77: # 78: # The array below are password error strings." 79: # 80: my $lastpwderror = 13; # Largest error number from lcpasswd. 81: my @passwderrors = ("ok", 82: "lcpasswd must be run as user 'www'", 83: "lcpasswd got incorrect number of arguments", 84: "lcpasswd did not get the right nubmer of input text lines", 85: "lcpasswd too many simultaneous pwd changes in progress", 86: "lcpasswd User does not exist.", 87: "lcpasswd Incorrect current passwd", 88: "lcpasswd Unable to su to root.", 89: "lcpasswd Cannot set new passwd.", 90: "lcpasswd Username has invalid characters", 91: "lcpasswd Invalid characters in password", 92: "11", "12", 93: "lcpasswd Password mismatch"); 94: 95: 96: # The array below are lcuseradd error strings.: 97: 98: my $lastadderror = 13; 99: my @adderrors = ("ok", 100: "User ID mismatch, lcuseradd must run as user www", 101: "lcuseradd Incorrect number of command line parameters must be 3", 102: "lcuseradd Incorrect number of stdinput lines, must be 3", 103: "lcuseradd Too many other simultaneous pwd changes in progress", 104: "lcuseradd User does not exist", 105: "lcuseradd Unabel to mak ewww member of users's group", 106: "lcuseradd Unable to su to root", 107: "lcuseradd Unable to set password", 108: "lcuseradd Usrname has invbalid charcters", 109: "lcuseradd Password has an invalid character", 110: "lcuseradd User already exists", 111: "lcuseradd Could not add user.", 112: "lcuseradd Password mismatch"); 113: 114: 115: # 116: # Convert an error return code from lcpasswd to a string value. 117: # 118: sub lcpasswdstrerror { 119: my $ErrorCode = shift; 120: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { 121: return "lcpasswd Unrecognized error return value ".$ErrorCode; 122: } else { 123: return $passwderrors[$ErrorCode]; 124: } 125: } 126: 127: # 128: # Convert an error return code from lcuseradd to a string value: 129: # 130: sub lcuseraddstrerror { 131: my $ErrorCode = shift; 132: if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) { 133: return "lcuseradd - Unrecognized error code: ".$ErrorCode; 134: } else { 135: return $adderrors[$ErrorCode]; 136: } 137: } 138: 139: # grabs exception and records it to log before exiting 140: sub catchexception { 141: my ($error)=@_; 142: $SIG{'QUIT'}='DEFAULT'; 143: $SIG{__DIE__}='DEFAULT'; 144: &logthis("<font color=red>CRITICAL: " 145: ."ABNORMAL EXIT. Child $$ for server $wasserver died through " 146: ."a crash with this error msg->[$error]</font>"); 147: &logthis('Famous last words: '.$status.' - '.$lastlog); 148: if ($client) { print $client "error: $error\n"; } 149: $server->close(); 150: die($error); 151: } 152: 153: sub timeout { 154: &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>"); 155: &catchexception('Timeout'); 156: } 157: # -------------------------------- Set signal handlers to record abnormal exits 158: 159: $SIG{'QUIT'}=\&catchexception; 160: $SIG{__DIE__}=\&catchexception; 161: 162: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf 163: &status("Read loncapa.conf and loncapa_apache.conf"); 164: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); 165: my %perlvar=%{$perlvarref}; 166: undef $perlvarref; 167: 168: # ----------------------------- Make sure this process is running from user=www 169: my $wwwid=getpwnam('www'); 170: if ($wwwid!=$<) { 171: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 172: $subj="LON: $perlvar{'lonHostID'} User ID mismatch"; 173: system("echo 'User ID mismatch. lond must be run as user www.' |\ 174: mailto $emailto -s '$subj' > /dev/null"); 175: exit 1; 176: } 177: 178: # --------------------------------------------- Check if other instance running 179: 180: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; 181: 182: if (-e $pidfile) { 183: my $lfh=IO::File->new("$pidfile"); 184: my $pide=<$lfh>; 185: chomp($pide); 186: if (kill 0 => $pide) { die "already running"; } 187: } 188: 189: $PREFORK=4; # number of children to maintain, at least four spare 190: 191: # ------------------------------------------------------------- Read hosts file 192: 193: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; 194: 195: while ($configline=<CONFIG>) { 196: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); 197: chomp($ip); $ip=~s/\D+$//; 198: $hostid{$ip}=$id; 199: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } 200: $PREFORK++; 201: } 202: close(CONFIG); 203: 204: # establish SERVER socket, bind and listen. 205: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'}, 206: Type => SOCK_STREAM, 207: Proto => 'tcp', 208: Reuse => 1, 209: Listen => 10 ) 210: or die "making socket: $@\n"; 211: 212: # --------------------------------------------------------- Do global variables 213: 214: # global variables 215: 216: $MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should 217: # process 218: %children = (); # keys are current child process IDs 219: $children = 0; # current number of children 220: 221: sub REAPER { # takes care of dead children 222: $SIG{CHLD} = \&REAPER; 223: my $pid = wait; 224: if (defined($children{$pid})) { 225: &logthis("Child $pid died"); 226: $children --; 227: delete $children{$pid}; 228: } else { 229: &logthis("Unknown Child $pid died"); 230: } 231: } 232: 233: sub HUNTSMAN { # signal handler for SIGINT 234: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 235: kill 'INT' => keys %children; 236: &logthis("Free socket: ".shutdown($server,2)); # free up socket 237: my $execdir=$perlvar{'lonDaemons'}; 238: unlink("$execdir/logs/lond.pid"); 239: &logthis("<font color=red>CRITICAL: Shutting down</font>"); 240: exit; # clean up with dignity 241: } 242: 243: sub HUPSMAN { # signal handler for SIGHUP 244: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 245: kill 'INT' => keys %children; 246: &logthis("Free socket: ".shutdown($server,2)); # free up socket 247: &logthis("<font color=red>CRITICAL: Restarting</font>"); 248: unlink("$execdir/logs/lond.pid"); 249: my $execdir=$perlvar{'lonDaemons'}; 250: exec("$execdir/lond"); # here we go again 251: } 252: 253: sub checkchildren { 254: &initnewstatus(); 255: &logstatus(); 256: &logthis('Going to check on the children'); 257: $docdir=$perlvar{'lonDocRoot'}; 258: foreach (sort keys %children) { 259: sleep 1; 260: unless (kill 'USR1' => $_) { 261: &logthis ('Child '.$_.' is dead'); 262: &logstatus($$.' is dead'); 263: } 264: } 265: sleep 5; 266: $SIG{ALRM} = sub { die "timeout" }; 267: $SIG{__DIE__} = 'DEFAULT'; 268: foreach (sort keys %children) { 269: unless (-e "$docdir/lon-status/londchld/$_.txt") { 270: eval { 271: alarm(300); 272: &logthis('Child '.$_.' did not respond'); 273: kill 9 => $_; 274: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 275: $subj="LON: $perlvar{'lonHostID'} killed lond process $_"; 276: my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; 277: $execdir=$perlvar{'lonDaemons'}; 278: $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; 279: alarm(0); 280: } 281: } 282: } 283: $SIG{ALRM} = 'DEFAULT'; 284: $SIG{__DIE__} = \&cathcexception; 285: } 286: 287: # --------------------------------------------------------------------- Logging 288: 289: sub logthis { 290: my $message=shift; 291: my $execdir=$perlvar{'lonDaemons'}; 292: my $fh=IO::File->new(">>$execdir/logs/lond.log"); 293: my $now=time; 294: my $local=localtime($now); 295: $lastlog=$local.': '.$message; 296: print $fh "$local ($$): $message\n"; 297: } 298: 299: # ------------------------- Conditional log if $DEBUG true. 300: sub Debug { 301: my $message = shift; 302: if($DEBUG) { 303: &logthis($message); 304: } 305: } 306: # ------------------------------------------------------------------ Log status 307: 308: sub logstatus { 309: my $docdir=$perlvar{'lonDocRoot'}; 310: { 311: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); 312: print $fh $$."\t".$status."\t".$lastlog."\n"; 313: $fh->close(); 314: } 315: { 316: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); 317: print $fh $status."\n".$lastlog."\n".time; 318: $fh->close(); 319: } 320: } 321: 322: sub initnewstatus { 323: my $docdir=$perlvar{'lonDocRoot'}; 324: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); 325: my $now=time; 326: my $local=localtime($now); 327: print $fh "LOND status $local - parent $$\n\n"; 328: opendir(DIR,"$docdir/lon-status/londchld"); 329: while ($filename=readdir(DIR)) { 330: unlink("$docdir/lon-status/londchld/$filename"); 331: } 332: closedir(DIR); 333: } 334: 335: # -------------------------------------------------------------- Status setting 336: 337: sub status { 338: my $what=shift; 339: my $now=time; 340: my $local=localtime($now); 341: $status=$local.': '.$what; 342: $0='lond: '.$what.' '.$local; 343: } 344: 345: # -------------------------------------------------------- Escape Special Chars 346: 347: sub escape { 348: my $str=shift; 349: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 350: return $str; 351: } 352: 353: # ----------------------------------------------------- Un-Escape Special Chars 354: 355: sub unescape { 356: my $str=shift; 357: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 358: return $str; 359: } 360: 361: # ----------------------------------------------------------- Send USR1 to lonc 362: 363: sub reconlonc { 364: my $peerfile=shift; 365: &logthis("Trying to reconnect for $peerfile"); 366: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 367: if (my $fh=IO::File->new("$loncfile")) { 368: my $loncpid=<$fh>; 369: chomp($loncpid); 370: if (kill 0 => $loncpid) { 371: &logthis("lonc at pid $loncpid responding, sending USR1"); 372: kill USR1 => $loncpid; 373: sleep 5; 374: if (-e "$peerfile") { return; } 375: &logthis("$peerfile still not there, give it another try"); 376: sleep 10; 377: if (-e "$peerfile") { return; } 378: &logthis( 379: "<font color=blue>WARNING: $peerfile still not there, giving up</font>"); 380: } else { 381: &logthis( 382: "<font color=red>CRITICAL: " 383: ."lonc at pid $loncpid not responding, giving up</font>"); 384: } 385: } else { 386: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>'); 387: } 388: } 389: 390: # -------------------------------------------------- Non-critical communication 391: 392: sub subreply { 393: my ($cmd,$server)=@_; 394: my $peerfile="$perlvar{'lonSockDir'}/$server"; 395: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 396: Type => SOCK_STREAM, 397: Timeout => 10) 398: or return "con_lost"; 399: print $sclient "$cmd\n"; 400: my $answer=<$sclient>; 401: chomp($answer); 402: if (!$answer) { $answer="con_lost"; } 403: return $answer; 404: } 405: 406: sub reply { 407: my ($cmd,$server)=@_; 408: my $answer; 409: if ($server ne $perlvar{'lonHostID'}) { 410: $answer=subreply($cmd,$server); 411: if ($answer eq 'con_lost') { 412: $answer=subreply("ping",$server); 413: if ($answer ne $server) { 414: &logthis("sub reply: answer != server"); 415: &reconlonc("$perlvar{'lonSockDir'}/$server"); 416: } 417: $answer=subreply($cmd,$server); 418: } 419: } else { 420: $answer='self_reply'; 421: } 422: return $answer; 423: } 424: 425: # -------------------------------------------------------------- Talk to lonsql 426: 427: sub sqlreply { 428: my ($cmd)=@_; 429: my $answer=subsqlreply($cmd); 430: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); } 431: return $answer; 432: } 433: 434: sub subsqlreply { 435: my ($cmd)=@_; 436: my $unixsock="mysqlsock"; 437: my $peerfile="$perlvar{'lonSockDir'}/$unixsock"; 438: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 439: Type => SOCK_STREAM, 440: Timeout => 10) 441: or return "con_lost"; 442: print $sclient "$cmd\n"; 443: my $answer=<$sclient>; 444: chomp($answer); 445: if (!$answer) { $answer="con_lost"; } 446: return $answer; 447: } 448: 449: # -------------------------------------------- Return path to profile directory 450: 451: sub propath { 452: my ($udom,$uname)=@_; 453: $udom=~s/\W//g; 454: $uname=~s/\W//g; 455: my $subdir=$uname.'__'; 456: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 457: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 458: return $proname; 459: } 460: 461: # --------------------------------------- Is this the home server of an author? 462: 463: sub ishome { 464: my $author=shift; 465: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 466: my ($udom,$uname)=split(/\//,$author); 467: my $proname=propath($udom,$uname); 468: if (-e $proname) { 469: return 'owner'; 470: } else { 471: return 'not_owner'; 472: } 473: } 474: 475: # ======================================================= Continue main program 476: # ---------------------------------------------------- Fork once and dissociate 477: 478: $fpid=fork; 479: exit if $fpid; 480: die "Couldn't fork: $!" unless defined ($fpid); 481: 482: POSIX::setsid() or die "Can't start new session: $!"; 483: 484: # ------------------------------------------------------- Write our PID on disk 485: 486: $execdir=$perlvar{'lonDaemons'}; 487: open (PIDSAVE,">$execdir/logs/lond.pid"); 488: print PIDSAVE "$$\n"; 489: close(PIDSAVE); 490: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); 491: &status('Starting'); 492: 493: 494: 495: # ----------------------------------------------------- Install signal handlers 496: 497: 498: $SIG{CHLD} = \&REAPER; 499: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 500: $SIG{HUP} = \&HUPSMAN; 501: $SIG{USR1} = \&checkchildren; 502: 503: 504: 505: # -------------------------------------------------------------- 506: # Accept connections. When a connection comes in, it is validated 507: # and if good, a child process is created to process transactions 508: # along the connection. 509: 510: while (1) { 511: $client = $server->accept() or next; 512: make_new_child($client); 513: } 514: 515: sub make_new_child { 516: my $client; 517: my $pid; 518: my $cipher; 519: my $sigset; 520: 521: $client = shift; 522: &logthis("Attempting to start child"); 523: # block signal for fork 524: $sigset = POSIX::SigSet->new(SIGINT); 525: sigprocmask(SIG_BLOCK, $sigset) 526: or die "Can't block SIGINT for fork: $!\n"; 527: 528: die "fork: $!" unless defined ($pid = fork); 529: 530: if ($pid) { 531: # Parent records the child's birth and returns. 532: sigprocmask(SIG_UNBLOCK, $sigset) 533: or die "Can't unblock SIGINT for fork: $!\n"; 534: $children{$pid} = 1; 535: $children++; 536: &status('Started child '.$pid); 537: return; 538: } else { 539: # Child can *not* return from this subroutine. 540: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before 541: $SIG{USR1}= \&logstatus; 542: $SIG{ALRM}= \&timeout; 543: $lastlog='Forked '; 544: $status='Forked'; 545: 546: # unblock signals 547: sigprocmask(SIG_UNBLOCK, $sigset) 548: or die "Can't unblock SIGINT for fork: $!\n"; 549: 550: $tmpsnum=0; 551: #---------------------------------------------------- kerberos 5 initialization 552: &Authen::Krb5::init_context(); 553: &Authen::Krb5::init_ets(); 554: 555: &status('Accepted connection'); 556: # ============================================================================= 557: # do something with the connection 558: # ----------------------------------------------------------------------------- 559: $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of 560: # connection liveness. 561: # see if we know client and check for spoof IP by challenge 562: my $caller = getpeername($client); 563: my ($port,$iaddr)=unpack_sockaddr_in($caller); 564: my $clientip=inet_ntoa($iaddr); 565: my $clientrec=($hostid{$clientip} ne undef); 566: &logthis( 567: "<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>" 568: ); 569: &status("Connecting $clientip ($hostid{$clientip})"); 570: my $clientok; 571: if ($clientrec) { 572: &status("Waiting for init from $clientip ($hostid{$clientip})"); 573: my $remotereq=<$client>; 574: $remotereq=~s/\W//g; 575: if ($remotereq eq 'init') { 576: my $challenge="$$".time; 577: print $client "$challenge\n"; 578: &status( 579: "Waiting for challenge reply from $clientip ($hostid{$clientip})"); 580: $remotereq=<$client>; 581: $remotereq=~s/\W//g; 582: if ($challenge eq $remotereq) { 583: $clientok=1; 584: print $client "ok\n"; 585: } else { 586: &logthis( 587: "<font color=blue>WARNING: $clientip did not reply challenge</font>"); 588: &status('No challenge reply '.$clientip); 589: } 590: } else { 591: &logthis( 592: "<font color=blue>WARNING: " 593: ."$clientip failed to initialize: >$remotereq< </font>"); 594: &status('No init '.$clientip); 595: } 596: } else { 597: &logthis( 598: "<font color=blue>WARNING: Unknown client $clientip</font>"); 599: &status('Hung up on '.$clientip); 600: } 601: if ($clientok) { 602: # ---------------- New known client connecting, could mean machine online again 603: 604: &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); 605: &logthis( 606: "<font color=green>Established connection: $hostid{$clientip}</font>"); 607: &status('Will listen to '.$hostid{$clientip}); 608: # ------------------------------------------------------------ Process requests 609: while (my $userinput=<$client>) { 610: chomp($userinput); 611: Debug("Request = $userinput\n"); 612: &status('Processing '.$hostid{$clientip}.': '.$userinput); 613: my $wasenc=0; 614: alarm(120); 615: # ------------------------------------------------------------ See if encrypted 616: if ($userinput =~ /^enc/) { 617: if ($cipher) { 618: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput); 619: $userinput=''; 620: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) { 621: $userinput.= 622: $cipher->decrypt( 623: pack("H16",substr($encinput,$encidx,16)) 624: ); 625: } 626: $userinput=substr($userinput,0,$cmdlength); 627: $wasenc=1; 628: } 629: } 630: 631: # ------------------------------------------------------------- Normal commands 632: # ------------------------------------------------------------------------ ping 633: if ($userinput =~ /^ping/) { 634: print $client "$perlvar{'lonHostID'}\n"; 635: # ------------------------------------------------------------------------ pong 636: } elsif ($userinput =~ /^pong/) { 637: $reply=reply("ping",$hostid{$clientip}); 638: print $client "$perlvar{'lonHostID'}:$reply\n"; 639: # ------------------------------------------------------------------------ ekey 640: } elsif ($userinput =~ /^ekey/) { 641: my $buildkey=time.$$.int(rand 100000); 642: $buildkey=~tr/1-6/A-F/; 643: $buildkey=int(rand 100000).$buildkey.int(rand 100000); 644: my $key=$perlvar{'lonHostID'}.$hostid{$clientip}; 645: $key=~tr/a-z/A-Z/; 646: $key=~tr/G-P/0-9/; 647: $key=~tr/Q-Z/0-9/; 648: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey; 649: $key=substr($key,0,32); 650: my $cipherkey=pack("H32",$key); 651: $cipher=new IDEA $cipherkey; 652: print $client "$buildkey\n"; 653: # ------------------------------------------------------------------------ load 654: } elsif ($userinput =~ /^load/) { 655: my $loadavg; 656: { 657: my $loadfile=IO::File->new('/proc/loadavg'); 658: $loadavg=<$loadfile>; 659: } 660: $loadavg =~ s/\s.*//g; 661: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; 662: print $client "$loadpercent\n"; 663: # ----------------------------------------------------------------- currentauth 664: } elsif ($userinput =~ /^currentauth/) { 665: if ($wasenc==1) { 666: my ($cmd,$udom,$uname)=split(/:/,$userinput); 667: my $result = GetAuthType($udom, $uname); 668: if($result eq "nouser") { 669: print $client "unknown_user\n"; 670: } 671: else { 672: print $client "$result\n" 673: } 674: } else { 675: print $client "refused\n"; 676: } 677: # ------------------------------------------------------------------------ auth 678: } elsif ($userinput =~ /^auth/) { 679: if ($wasenc==1) { 680: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput); 681: chomp($upass); 682: $upass=unescape($upass); 683: my $proname=propath($udom,$uname); 684: my $passfilename="$proname/passwd"; 685: if (-e $passfilename) { 686: my $pf = IO::File->new($passfilename); 687: my $realpasswd=<$pf>; 688: chomp($realpasswd); 689: my ($howpwd,$contentpwd)=split(/:/,$realpasswd); 690: my $pwdcorrect=0; 691: if ($howpwd eq 'internal') { 692: &Debug("Internal auth"); 693: $pwdcorrect= 694: (crypt($upass,$contentpwd) eq $contentpwd); 695: } elsif ($howpwd eq 'unix') { 696: &Debug("Unix auth"); 697: if((getpwnam($uname))[1] eq "") { #no such user! 698: $pwdcorrect = 0; 699: } else { 700: $contentpwd=(getpwnam($uname))[1]; 701: my $pwauth_path="/usr/local/sbin/pwauth"; 702: unless ($contentpwd eq 'x') { 703: $pwdcorrect= 704: (crypt($upass,$contentpwd) eq 705: $contentpwd); 706: } 707: 708: elsif (-e $pwauth_path) { 709: open PWAUTH, "|$pwauth_path" or 710: die "Cannot invoke authentication"; 711: print PWAUTH "$uname\n$upass\n"; 712: close PWAUTH; 713: $pwdcorrect=!$?; 714: } 715: } 716: } elsif ($howpwd eq 'krb4') { 717: $null=pack("C",0); 718: unless ($upass=~/$null/) { 719: my $krb4_error = &Authen::Krb4::get_pw_in_tkt 720: ($uname,"",$contentpwd,'krbtgt', 721: $contentpwd,1,$upass); 722: if (!$krb4_error) { 723: $pwdcorrect = 1; 724: } else { 725: $pwdcorrect=0; 726: # log error if it is not a bad password 727: if ($krb4_error != 62) { 728: &logthis('krb4:'.$uname.','.$contentpwd.','. 729: &Authen::Krb4::get_err_txt($Authen::Krb4::error)); 730: } 731: } 732: } 733: } elsif ($howpwd eq 'krb5') { 734: $null=pack("C",0); 735: unless ($upass=~/$null/) { 736: my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); 737: my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; 738: my $krbserver=&Authen::Krb5::parse_name($krbservice); 739: my $credentials=&Authen::Krb5::cc_default(); 740: $credentials->initialize($krbclient); 741: my $krbreturn = 742: &Authen::Krb5::get_in_tkt_with_password( 743: $krbclient,$krbserver,$upass,$credentials); 744: # unless ($krbreturn) { 745: # &logthis("Krb5 Error: ". 746: # &Authen::Krb5::error()); 747: # } 748: $pwdcorrect = ($krbreturn == 1); 749: } else { $pwdcorrect=0; } 750: } elsif ($howpwd eq 'localauth') { 751: $pwdcorrect=&localauth::localauth($uname,$upass, 752: $contentpwd); 753: } 754: if ($pwdcorrect) { 755: print $client "authorized\n"; 756: } else { 757: print $client "non_authorized\n"; 758: } 759: } else { 760: print $client "unknown_user\n"; 761: } 762: } else { 763: print $client "refused\n"; 764: } 765: # ---------------------------------------------------------------------- passwd 766: } elsif ($userinput =~ /^passwd/) { 767: if ($wasenc==1) { 768: my 769: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); 770: chomp($npass); 771: $upass=&unescape($upass); 772: $npass=&unescape($npass); 773: &Debug("Trying to change password for $uname"); 774: my $proname=propath($udom,$uname); 775: my $passfilename="$proname/passwd"; 776: if (-e $passfilename) { 777: my $realpasswd; 778: { my $pf = IO::File->new($passfilename); 779: $realpasswd=<$pf>; } 780: chomp($realpasswd); 781: my ($howpwd,$contentpwd)=split(/:/,$realpasswd); 782: if ($howpwd eq 'internal') { 783: &Debug("internal auth"); 784: if (crypt($upass,$contentpwd) eq $contentpwd) { 785: my $salt=time; 786: $salt=substr($salt,6,2); 787: my $ncpass=crypt($npass,$salt); 788: { my $pf = IO::File->new(">$passfilename"); 789: print $pf "internal:$ncpass\n"; } 790: &logthis("Result of password change for $uname: pwchange_success"); 791: print $client "ok\n"; 792: } else { 793: print $client "non_authorized\n"; 794: } 795: } elsif ($howpwd eq 'unix') { 796: # Unix means we have to access /etc/password 797: # one way or another. 798: # First: Make sure the current password is 799: # correct 800: &Debug("auth is unix"); 801: $contentpwd=(getpwnam($uname))[1]; 802: my $pwdcorrect = "0"; 803: my $pwauth_path="/usr/local/sbin/pwauth"; 804: unless ($contentpwd eq 'x') { 805: $pwdcorrect= 806: (crypt($upass,$contentpwd) eq $contentpwd); 807: } elsif (-e $pwauth_path) { 808: open PWAUTH, "|$pwauth_path" or 809: die "Cannot invoke authentication"; 810: print PWAUTH "$uname\n$upass\n"; 811: close PWAUTH; 812: &Debug("exited pwauth with $? ($uname,$upass) "); 813: $pwdcorrect=($? == 0); 814: } 815: if ($pwdcorrect) { 816: my $execdir=$perlvar{'lonDaemons'}; 817: &Debug("Opening lcpasswd pipeline"); 818: my $pf = IO::File->new("|$execdir/lcpasswd > /home/www/lcpasswd.log"); 819: print $pf "$uname\n$npass\n$npass\n"; 820: close $pf; 821: my $err = $?; 822: my $result = ($err>0 ? 'pwchange_failure' 823: : 'ok'); 824: &logthis("Result of password change for $uname: ". 825: &lcpasswdstrerror($?)); 826: print $client "$result\n"; 827: } else { 828: print $client "non_authorized\n"; 829: } 830: } else { 831: print $client "auth_mode_error\n"; 832: } 833: } else { 834: print $client "unknown_user\n"; 835: } 836: } else { 837: print $client "refused\n"; 838: } 839: # -------------------------------------------------------------------- makeuser 840: } elsif ($userinput =~ /^makeuser/) { 841: &Debug("Make user received"); 842: my $oldumask=umask(0077); 843: if ($wasenc==1) { 844: my 845: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); 846: &Debug("cmd =".$cmd." $udom =".$udom. 847: " uname=".$uname); 848: chomp($npass); 849: $npass=&unescape($npass); 850: my $proname=propath($udom,$uname); 851: my $passfilename="$proname/passwd"; 852: &Debug("Password file created will be:". 853: $passfilename); 854: if (-e $passfilename) { 855: print $client "already_exists\n"; 856: } elsif ($udom ne $perlvar{'lonDefDomain'}) { 857: print $client "not_right_domain\n"; 858: } else { 859: @fpparts=split(/\//,$proname); 860: $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; 861: $fperror=''; 862: for ($i=3;$i<=$#fpparts;$i++) { 863: $fpnow.='/'.$fpparts[$i]; 864: unless (-e $fpnow) { 865: unless (mkdir($fpnow,0777)) { 866: $fperror="error: ".($!+0) 867: ." mkdir failed while attempting " 868: ."makeuser\n"; 869: } 870: } 871: } 872: unless ($fperror) { 873: my $result=&make_passwd_file($uname, $umode,$npass, 874: $passfilename); 875: print $client $result; 876: } else { 877: print $client "$fperror\n"; 878: } 879: } 880: } else { 881: print $client "refused\n"; 882: } 883: umask($oldumask); 884: # -------------------------------------------------------------- changeuserauth 885: } elsif ($userinput =~ /^changeuserauth/) { 886: &Debug("Changing authorization"); 887: if ($wasenc==1) { 888: my 889: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); 890: chomp($npass); 891: &Debug("cmd = ".$cmd." domain= ".$udom. 892: "uname =".$uname." umode= ".$umode); 893: $npass=&unescape($npass); 894: my $proname=&propath($udom,$uname); 895: my $passfilename="$proname/passwd"; 896: if ($udom ne $perlvar{'lonDefDomain'}) { 897: print $client "not_right_domain\n"; 898: } else { 899: my $result=&make_passwd_file($uname, $umode,$npass, 900: $passfilename); 901: print $client $result; 902: } 903: } else { 904: print $client "refused\n"; 905: } 906: # ------------------------------------------------------------------------ home 907: } elsif ($userinput =~ /^home/) { 908: my ($cmd,$udom,$uname)=split(/:/,$userinput); 909: chomp($uname); 910: my $proname=propath($udom,$uname); 911: if (-e $proname) { 912: print $client "found\n"; 913: } else { 914: print $client "not_found\n"; 915: } 916: # ---------------------------------------------------------------------- update 917: } elsif ($userinput =~ /^update/) { 918: my ($cmd,$fname)=split(/:/,$userinput); 919: my $ownership=ishome($fname); 920: if ($ownership eq 'not_owner') { 921: if (-e $fname) { 922: my ($dev,$ino,$mode,$nlink, 923: $uid,$gid,$rdev,$size, 924: $atime,$mtime,$ctime, 925: $blksize,$blocks)=stat($fname); 926: $now=time; 927: $since=$now-$atime; 928: if ($since>$perlvar{'lonExpire'}) { 929: $reply= 930: reply("unsub:$fname","$hostid{$clientip}"); 931: unlink("$fname"); 932: } else { 933: my $transname="$fname.in.transfer"; 934: my $remoteurl= 935: reply("sub:$fname","$hostid{$clientip}"); 936: my $response; 937: { 938: my $ua=new LWP::UserAgent; 939: my $request=new HTTP::Request('GET',"$remoteurl"); 940: $response=$ua->request($request,$transname); 941: } 942: if ($response->is_error()) { 943: unlink($transname); 944: my $message=$response->status_line; 945: &logthis( 946: "LWP GET: $message for $fname ($remoteurl)"); 947: } else { 948: if ($remoteurl!~/\.meta$/) { 949: my $ua=new LWP::UserAgent; 950: my $mrequest= 951: new HTTP::Request('GET',$remoteurl.'.meta'); 952: my $mresponse= 953: $ua->request($mrequest,$fname.'.meta'); 954: if ($mresponse->is_error()) { 955: unlink($fname.'.meta'); 956: } 957: } 958: rename($transname,$fname); 959: } 960: } 961: print $client "ok\n"; 962: } else { 963: print $client "not_found\n"; 964: } 965: } else { 966: print $client "rejected\n"; 967: } 968: # -------------------------------------- fetch a user file from a remote server 969: } elsif ($userinput =~ /^fetchuserfile/) { 970: my ($cmd,$fname)=split(/:/,$userinput); 971: my ($udom,$uname,$ufile)=split(/\//,$fname); 972: my $udir=propath($udom,$uname).'/userfiles'; 973: unless (-e $udir) { mkdir($udir,0770); } 974: if (-e $udir) { 975: $ufile=~s/^[\.\~]+//; 976: $ufile=~s/\///g; 977: my $transname=$udir.'/'.$ufile; 978: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; 979: my $response; 980: { 981: my $ua=new LWP::UserAgent; 982: my $request=new HTTP::Request('GET',"$remoteurl"); 983: $response=$ua->request($request,$transname); 984: } 985: if ($response->is_error()) { 986: unlink($transname); 987: my $message=$response->status_line; 988: &logthis( 989: "LWP GET: $message for $fname ($remoteurl)"); 990: print $client "failed\n"; 991: } else { 992: print $client "ok\n"; 993: } 994: } else { 995: print $client "not_home\n"; 996: } 997: # ------------------------------------------ authenticate access to a user file 998: } elsif ($userinput =~ /^tokenauthuserfile/) { 999: my ($cmd,$fname,$session)=split(/:/,$userinput); 1000: chomp($session); 1001: $reply='non_auth'; 1002: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. 1003: $session.'.id')) { 1004: while ($line=<ENVIN>) { 1005: if ($line=~/userfile\.$fname\=/) { $reply='ok'; } 1006: } 1007: close(ENVIN); 1008: print $client $reply."\n"; 1009: } else { 1010: print $client "invalid_token\n"; 1011: } 1012: # ----------------------------------------------------------------- unsubscribe 1013: } elsif ($userinput =~ /^unsub/) { 1014: my ($cmd,$fname)=split(/:/,$userinput); 1015: if (-e $fname) { 1016: print $client &unsub($client,$fname,$clientip); 1017: } else { 1018: print $client "not_found\n"; 1019: } 1020: # ------------------------------------------------------------------- subscribe 1021: } elsif ($userinput =~ /^sub/) { 1022: print $client &subscribe($userinput,$clientip); 1023: # ------------------------------------------------------------- current version 1024: } elsif ($userinput =~ /^currentversion/) { 1025: my ($cmd,$fname)=split(/:/,$userinput); 1026: print $client ¤tversion($fname)."\n"; 1027: # ------------------------------------------------------------------------- log 1028: } elsif ($userinput =~ /^log/) { 1029: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); 1030: chomp($what); 1031: my $proname=propath($udom,$uname); 1032: my $now=time; 1033: { 1034: my $hfh; 1035: if ($hfh=IO::File->new(">>$proname/activity.log")) { 1036: print $hfh "$now:$hostid{$clientip}:$what\n"; 1037: print $client "ok\n"; 1038: } else { 1039: print $client "error: ".($!+0) 1040: ." IO::File->new Failed " 1041: ."while attempting log\n"; 1042: } 1043: } 1044: # ------------------------------------------------------------------------- put 1045: } elsif ($userinput =~ /^put/) { 1046: my ($cmd,$udom,$uname,$namespace,$what) 1047: =split(/:/,$userinput); 1048: $namespace=~s/\//\_/g; 1049: $namespace=~s/\W//g; 1050: if ($namespace ne 'roles') { 1051: chomp($what); 1052: my $proname=propath($udom,$uname); 1053: my $now=time; 1054: unless ($namespace=~/^nohist\_/) { 1055: my $hfh; 1056: if ( 1057: $hfh=IO::File->new(">>$proname/$namespace.hist") 1058: ) { print $hfh "P:$now:$what\n"; } 1059: } 1060: my @pairs=split(/\&/,$what); 1061: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { 1062: foreach $pair (@pairs) { 1063: ($key,$value)=split(/=/,$pair); 1064: $hash{$key}=$value; 1065: } 1066: if (untie(%hash)) { 1067: print $client "ok\n"; 1068: } else { 1069: print $client "error: ".($!+0) 1070: ." untie(GDBM) failed ". 1071: "while attempting put\n"; 1072: } 1073: } else { 1074: print $client "error: ".($!) 1075: ." tie(GDBM) Failed ". 1076: "while attempting put\n"; 1077: } 1078: } else { 1079: print $client "refused\n"; 1080: } 1081: # -------------------------------------------------------------------- rolesput 1082: } elsif ($userinput =~ /^rolesput/) { 1083: &Debug("rolesput"); 1084: if ($wasenc==1) { 1085: my ($cmd,$exedom,$exeuser,$udom,$uname,$what) 1086: =split(/:/,$userinput); 1087: &Debug("cmd = ".$cmd." exedom= ".$exedom. 1088: "user = ".$exeuser." udom=".$udom. 1089: "what = ".$what); 1090: my $namespace='roles'; 1091: chomp($what); 1092: my $proname=propath($udom,$uname); 1093: my $now=time; 1094: { 1095: my $hfh; 1096: if ( 1097: $hfh=IO::File->new(">>$proname/$namespace.hist") 1098: ) { 1099: print $hfh "P:$now:$exedom:$exeuser:$what\n"; 1100: } 1101: } 1102: my @pairs=split(/\&/,$what); 1103: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { 1104: foreach $pair (@pairs) { 1105: ($key,$value)=split(/=/,$pair); 1106: &ManagePermissions($key, $udom, $uname, 1107: &GetAuthType( $udom, 1108: $uname)); 1109: $hash{$key}=$value; 1110: 1111: } 1112: if (untie(%hash)) { 1113: print $client "ok\n"; 1114: } else { 1115: print $client "error: ".($!+0) 1116: ." untie(GDBM) Failed ". 1117: "while attempting rolesput\n"; 1118: } 1119: } else { 1120: print $client "error: ".($!+0) 1121: ." tie(GDBM) Failed ". 1122: "while attempting rolesput\n"; 1123: } 1124: } else { 1125: print $client "refused\n"; 1126: } 1127: # ------------------------------------------------------------------------- get 1128: } elsif ($userinput =~ /^get/) { 1129: my ($cmd,$udom,$uname,$namespace,$what) 1130: =split(/:/,$userinput); 1131: $namespace=~s/\//\_/g; 1132: $namespace=~s/\W//g; 1133: chomp($what); 1134: my @queries=split(/\&/,$what); 1135: my $proname=propath($udom,$uname); 1136: my $qresult=''; 1137: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { 1138: for ($i=0;$i<=$#queries;$i++) { 1139: $qresult.="$hash{$queries[$i]}&"; 1140: } 1141: if (untie(%hash)) { 1142: $qresult=~s/\&$//; 1143: print $client "$qresult\n"; 1144: } else { 1145: print $client "error: ".($!+0) 1146: ." untie(GDBM) Failed ". 1147: "while attempting get\n"; 1148: } 1149: } else { 1150: if ($!+0 == 2) { 1151: print $client "error:No such file or ". 1152: "GDBM reported bad block error\n"; 1153: } else { 1154: print $client "error: ".($!+0) 1155: ." tie(GDBM) Failed ". 1156: "while attempting get\n"; 1157: } 1158: } 1159: # ------------------------------------------------------------------------ eget 1160: } elsif ($userinput =~ /^eget/) { 1161: my ($cmd,$udom,$uname,$namespace,$what) 1162: =split(/:/,$userinput); 1163: $namespace=~s/\//\_/g; 1164: $namespace=~s/\W//g; 1165: chomp($what); 1166: my @queries=split(/\&/,$what); 1167: my $proname=propath($udom,$uname); 1168: my $qresult=''; 1169: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { 1170: for ($i=0;$i<=$#queries;$i++) { 1171: $qresult.="$hash{$queries[$i]}&"; 1172: } 1173: if (untie(%hash)) { 1174: $qresult=~s/\&$//; 1175: if ($cipher) { 1176: my $cmdlength=length($qresult); 1177: $qresult.=" "; 1178: my $encqresult=''; 1179: for 1180: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { 1181: $encqresult.= 1182: unpack("H16", 1183: $cipher->encrypt(substr($qresult,$encidx,8))); 1184: } 1185: print $client "enc:$cmdlength:$encqresult\n"; 1186: } else { 1187: print $client "error:no_key\n"; 1188: } 1189: } else { 1190: print $client "error: ".($!+0) 1191: ." untie(GDBM) Failed ". 1192: "while attempting eget\n"; 1193: } 1194: } else { 1195: print $client "error: ".($!+0) 1196: ." tie(GDBM) Failed ". 1197: "while attempting eget\n"; 1198: } 1199: # ------------------------------------------------------------------------- del 1200: } elsif ($userinput =~ /^del/) { 1201: my ($cmd,$udom,$uname,$namespace,$what) 1202: =split(/:/,$userinput); 1203: $namespace=~s/\//\_/g; 1204: $namespace=~s/\W//g; 1205: chomp($what); 1206: my $proname=propath($udom,$uname); 1207: my $now=time; 1208: unless ($namespace=~/^nohist\_/) { 1209: my $hfh; 1210: if ( 1211: $hfh=IO::File->new(">>$proname/$namespace.hist") 1212: ) { print $hfh "D:$now:$what\n"; } 1213: } 1214: my @keys=split(/\&/,$what); 1215: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { 1216: foreach $key (@keys) { 1217: delete($hash{$key}); 1218: } 1219: if (untie(%hash)) { 1220: print $client "ok\n"; 1221: } else { 1222: print $client "error: ".($!+0) 1223: ." untie(GDBM) Failed ". 1224: "while attempting del\n"; 1225: } 1226: } else { 1227: print $client "error: ".($!+0) 1228: ." tie(GDBM) Failed ". 1229: "while attempting del\n"; 1230: } 1231: # ------------------------------------------------------------------------ keys 1232: } elsif ($userinput =~ /^keys/) { 1233: my ($cmd,$udom,$uname,$namespace) 1234: =split(/:/,$userinput); 1235: $namespace=~s/\//\_/g; 1236: $namespace=~s/\W//g; 1237: my $proname=propath($udom,$uname); 1238: my $qresult=''; 1239: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { 1240: foreach $key (keys %hash) { 1241: $qresult.="$key&"; 1242: } 1243: if (untie(%hash)) { 1244: $qresult=~s/\&$//; 1245: print $client "$qresult\n"; 1246: } else { 1247: print $client "error: ".($!+0) 1248: ." untie(GDBM) Failed ". 1249: "while attempting keys\n"; 1250: } 1251: } else { 1252: print $client "error: ".($!+0) 1253: ." tie(GDBM) Failed ". 1254: "while attempting keys\n"; 1255: } 1256: # ----------------------------------------------------------------- dumpcurrent 1257: } elsif ($userinput =~ /^currentdump/) { 1258: my ($cmd,$udom,$uname,$namespace) 1259: =split(/:/,$userinput); 1260: $namespace=~s/\//\_/g; 1261: $namespace=~s/\W//g; 1262: my $qresult=''; 1263: my $proname=propath($udom,$uname); 1264: if (tie(%hash,'GDBM_File', 1265: "$proname/$namespace.db", 1266: &GDBM_READER(),0640)) { 1267: # Structure of %data: 1268: # $data{$symb}->{$parameter}=$value; 1269: # $data{$symb}->{'v.'.$parameter}=$version; 1270: # since $parameter will be unescaped, we do not 1271: # have to worry about silly parameter names... 1272: my %data = (); 1273: while (my ($key,$value) = each(%hash)) { 1274: my ($v,$symb,$param) = split(/:/,$key); 1275: next if ($v eq 'version' || $symb eq 'keys'); 1276: next if (exists($data{$symb}) && 1277: exists($data{$symb}->{$param}) && 1278: $data{$symb}->{'v.'.$param} > $v); 1279: $data{$symb}->{$param}=$value; 1280: $data{$symb}->{'v.'.$param}=$v; 1281: } 1282: if (untie(%hash)) { 1283: while (my ($symb,$param_hash) = each(%data)) { 1284: while(my ($param,$value) = each (%$param_hash)){ 1285: next if ($param =~ /^v\./); 1286: $qresult.=$symb.':'.$param.'='.$value.'&'; 1287: } 1288: } 1289: chop($qresult); 1290: print $client "$qresult\n"; 1291: } else { 1292: print $client "error: ".($!+0) 1293: ." untie(GDBM) Failed ". 1294: "while attempting currentdump\n"; 1295: } 1296: } else { 1297: print $client "error: ".($!+0) 1298: ." tie(GDBM) Failed ". 1299: "while attempting currentdump\n"; 1300: } 1301: # ------------------------------------------------------------------------ dump 1302: } elsif ($userinput =~ /^dump/) { 1303: my ($cmd,$udom,$uname,$namespace,$regexp) 1304: =split(/:/,$userinput); 1305: $namespace=~s/\//\_/g; 1306: $namespace=~s/\W//g; 1307: if (defined($regexp)) { 1308: $regexp=&unescape($regexp); 1309: } else { 1310: $regexp='.'; 1311: } 1312: my $qresult=''; 1313: my $proname=propath($udom,$uname); 1314: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { 1315: study($regexp); 1316: while (($key,$value) = each(%hash)) { 1317: if ($regexp eq '.') { 1318: $qresult.=$key.'='.$value.'&'; 1319: } else { 1320: my $unescapeKey = &unescape($key); 1321: if (eval('$unescapeKey=~/$regexp/')) { 1322: $qresult.="$key=$value&"; 1323: } 1324: } 1325: } 1326: if (untie(%hash)) { 1327: chop($qresult); 1328: print $client "$qresult\n"; 1329: } else { 1330: print $client "error: ".($!+0) 1331: ." untie(GDBM) Failed ". 1332: "while attempting dump\n"; 1333: } 1334: } else { 1335: print $client "error: ".($!+0) 1336: ." tie(GDBM) Failed ". 1337: "while attempting dump\n"; 1338: } 1339: # ----------------------------------------------------------------------- store 1340: } elsif ($userinput =~ /^store/) { 1341: my ($cmd,$udom,$uname,$namespace,$rid,$what) 1342: =split(/:/,$userinput); 1343: $namespace=~s/\//\_/g; 1344: $namespace=~s/\W//g; 1345: if ($namespace ne 'roles') { 1346: chomp($what); 1347: my $proname=propath($udom,$uname); 1348: my $now=time; 1349: unless ($namespace=~/^nohist\_/) { 1350: my $hfh; 1351: if ( 1352: $hfh=IO::File->new(">>$proname/$namespace.hist") 1353: ) { print $hfh "P:$now:$rid:$what\n"; } 1354: } 1355: my @pairs=split(/\&/,$what); 1356: 1357: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { 1358: my @previouskeys=split(/&/,$hash{"keys:$rid"}); 1359: my $key; 1360: $hash{"version:$rid"}++; 1361: my $version=$hash{"version:$rid"}; 1362: my $allkeys=''; 1363: foreach $pair (@pairs) { 1364: ($key,$value)=split(/=/,$pair); 1365: $allkeys.=$key.':'; 1366: $hash{"$version:$rid:$key"}=$value; 1367: } 1368: $hash{"$version:$rid:timestamp"}=$now; 1369: $allkeys.='timestamp'; 1370: $hash{"$version:keys:$rid"}=$allkeys; 1371: if (untie(%hash)) { 1372: print $client "ok\n"; 1373: } else { 1374: print $client "error: ".($!+0) 1375: ." untie(GDBM) Failed ". 1376: "while attempting store\n"; 1377: } 1378: } else { 1379: print $client "error: ".($!+0) 1380: ." tie(GDBM) Failed ". 1381: "while attempting store\n"; 1382: } 1383: } else { 1384: print $client "refused\n"; 1385: } 1386: # --------------------------------------------------------------------- restore 1387: } elsif ($userinput =~ /^restore/) { 1388: my ($cmd,$udom,$uname,$namespace,$rid) 1389: =split(/:/,$userinput); 1390: $namespace=~s/\//\_/g; 1391: $namespace=~s/\W//g; 1392: chomp($rid); 1393: my $proname=propath($udom,$uname); 1394: my $qresult=''; 1395: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { 1396: my $version=$hash{"version:$rid"}; 1397: $qresult.="version=$version&"; 1398: my $scope; 1399: for ($scope=1;$scope<=$version;$scope++) { 1400: my $vkeys=$hash{"$scope:keys:$rid"}; 1401: my @keys=split(/:/,$vkeys); 1402: my $key; 1403: $qresult.="$scope:keys=$vkeys&"; 1404: foreach $key (@keys) { 1405: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; 1406: } 1407: } 1408: if (untie(%hash)) { 1409: $qresult=~s/\&$//; 1410: print $client "$qresult\n"; 1411: } else { 1412: print $client "error: ".($!+0) 1413: ." untie(GDBM) Failed ". 1414: "while attempting restore\n"; 1415: } 1416: } else { 1417: print $client "error: ".($!+0) 1418: ." tie(GDBM) Failed ". 1419: "while attempting restore\n"; 1420: } 1421: # -------------------------------------------------------------------- chatsend 1422: } elsif ($userinput =~ /^chatsend/) { 1423: my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); 1424: &chatadd($cdom,$cnum,$newpost); 1425: print $client "ok\n"; 1426: # -------------------------------------------------------------------- chatretr 1427: } elsif ($userinput =~ /^chatretr/) { 1428: my ($cmd,$cdom,$cnum)=split(/\:/,$userinput); 1429: my $reply=''; 1430: foreach (&getchat($cdom,$cnum)) { 1431: $reply.=&escape($_).':'; 1432: } 1433: $reply=~s/\:$//; 1434: print $client $reply."\n"; 1435: # ------------------------------------------------------------------- querysend 1436: } elsif ($userinput =~ /^querysend/) { 1437: my ($cmd,$query, 1438: $arg1,$arg2,$arg3)=split(/\:/,$userinput); 1439: $query=~s/\n*$//g; 1440: print $client "". 1441: sqlreply("$hostid{$clientip}\&$query". 1442: "\&$arg1"."\&$arg2"."\&$arg3")."\n"; 1443: # ------------------------------------------------------------------ queryreply 1444: } elsif ($userinput =~ /^queryreply/) { 1445: my ($cmd,$id,$reply)=split(/:/,$userinput); 1446: my $store; 1447: my $execdir=$perlvar{'lonDaemons'}; 1448: if ($store=IO::File->new(">$execdir/tmp/$id")) { 1449: $reply=~s/\&/\n/g; 1450: print $store $reply; 1451: close $store; 1452: my $store2=IO::File->new(">$execdir/tmp/$id.end"); 1453: print $store2 "done\n"; 1454: close $store2; 1455: print $client "ok\n"; 1456: } 1457: else { 1458: print $client "error: ".($!+0) 1459: ." IO::File->new Failed ". 1460: "while attempting queryreply\n"; 1461: } 1462: # ----------------------------------------------------------------------- idput 1463: } elsif ($userinput =~ /^idput/) { 1464: my ($cmd,$udom,$what)=split(/:/,$userinput); 1465: chomp($what); 1466: $udom=~s/\W//g; 1467: my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; 1468: my $now=time; 1469: { 1470: my $hfh; 1471: if ( 1472: $hfh=IO::File->new(">>$proname.hist") 1473: ) { print $hfh "P:$now:$what\n"; } 1474: } 1475: my @pairs=split(/\&/,$what); 1476: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { 1477: foreach $pair (@pairs) { 1478: ($key,$value)=split(/=/,$pair); 1479: $hash{$key}=$value; 1480: } 1481: if (untie(%hash)) { 1482: print $client "ok\n"; 1483: } else { 1484: print $client "error: ".($!+0) 1485: ." untie(GDBM) Failed ". 1486: "while attempting idput\n"; 1487: } 1488: } else { 1489: print $client "error: ".($!+0) 1490: ." tie(GDBM) Failed ". 1491: "while attempting idput\n"; 1492: } 1493: # ----------------------------------------------------------------------- idget 1494: } elsif ($userinput =~ /^idget/) { 1495: my ($cmd,$udom,$what)=split(/:/,$userinput); 1496: chomp($what); 1497: $udom=~s/\W//g; 1498: my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; 1499: my @queries=split(/\&/,$what); 1500: my $qresult=''; 1501: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { 1502: for ($i=0;$i<=$#queries;$i++) { 1503: $qresult.="$hash{$queries[$i]}&"; 1504: } 1505: if (untie(%hash)) { 1506: $qresult=~s/\&$//; 1507: print $client "$qresult\n"; 1508: } else { 1509: print $client "error: ".($!+0) 1510: ." untie(GDBM) Failed ". 1511: "while attempting idget\n"; 1512: } 1513: } else { 1514: print $client "error: ".($!+0) 1515: ." tie(GDBM) Failed ". 1516: "while attempting idget\n"; 1517: } 1518: # ---------------------------------------------------------------------- tmpput 1519: } elsif ($userinput =~ /^tmpput/) { 1520: my ($cmd,$what)=split(/:/,$userinput); 1521: my $store; 1522: $tmpsnum++; 1523: my $id=$$.'_'.$clientip.'_'.$tmpsnum; 1524: $id=~s/\W/\_/g; 1525: $what=~s/\n//g; 1526: my $execdir=$perlvar{'lonDaemons'}; 1527: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { 1528: print $store $what; 1529: close $store; 1530: print $client "$id\n"; 1531: } 1532: else { 1533: print $client "error: ".($!+0) 1534: ."IO::File->new Failed ". 1535: "while attempting tmpput\n"; 1536: } 1537: 1538: # ---------------------------------------------------------------------- tmpget 1539: } elsif ($userinput =~ /^tmpget/) { 1540: my ($cmd,$id)=split(/:/,$userinput); 1541: chomp($id); 1542: $id=~s/\W/\_/g; 1543: my $store; 1544: my $execdir=$perlvar{'lonDaemons'}; 1545: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { 1546: my $reply=<$store>; 1547: print $client "$reply\n"; 1548: close $store; 1549: } 1550: else { 1551: print $client "error: ".($!+0) 1552: ."IO::File->new Failed ". 1553: "while attempting tmpget\n"; 1554: } 1555: 1556: # ---------------------------------------------------------------------- tmpdel 1557: } elsif ($userinput =~ /^tmpdel/) { 1558: my ($cmd,$id)=split(/:/,$userinput); 1559: chomp($id); 1560: $id=~s/\W/\_/g; 1561: my $execdir=$perlvar{'lonDaemons'}; 1562: if (unlink("$execdir/tmp/$id.tmp")) { 1563: print $client "ok\n"; 1564: } else { 1565: print $client "error: ".($!+0) 1566: ."Unlink tmp Failed ". 1567: "while attempting tmpdel\n"; 1568: } 1569: # -------------------------------------------------------------------------- ls 1570: } elsif ($userinput =~ /^ls/) { 1571: my ($cmd,$ulsdir)=split(/:/,$userinput); 1572: my $ulsout=''; 1573: my $ulsfn; 1574: if (-e $ulsdir) { 1575: if(-d $ulsdir) { 1576: if (opendir(LSDIR,$ulsdir)) { 1577: while ($ulsfn=readdir(LSDIR)) { 1578: my @ulsstats=stat($ulsdir.'/'.$ulsfn); 1579: $ulsout.=$ulsfn.'&'. 1580: join('&',@ulsstats).':'; 1581: } 1582: closedir(LSDIR); 1583: } 1584: } else { 1585: my @ulsstats=stat($ulsdir); 1586: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; 1587: } 1588: } else { 1589: $ulsout='no_such_dir'; 1590: } 1591: if ($ulsout eq '') { $ulsout='empty'; } 1592: print $client "$ulsout\n"; 1593: # ------------------------------------------------------------------ Hanging up 1594: } elsif (($userinput =~ /^exit/) || 1595: ($userinput =~ /^init/)) { 1596: &logthis( 1597: "Client $clientip ($hostid{$clientip}) hanging up: $userinput"); 1598: print $client "bye\n"; 1599: $client->close(); 1600: last; 1601: # ------------------------------------------------------------- unknown command 1602: } else { 1603: # unknown command 1604: print $client "unknown_cmd\n"; 1605: } 1606: # -------------------------------------------------------------------- complete 1607: alarm(0); 1608: &status('Listening to '.$hostid{$clientip}); 1609: } 1610: # --------------------------------------------- client unknown or fishy, refuse 1611: } else { 1612: print $client "refused\n"; 1613: $client->close(); 1614: &logthis("<font color=blue>WARNING: " 1615: ."Rejected client $clientip, closing connection</font>"); 1616: } 1617: } 1618: 1619: # ============================================================================= 1620: 1621: &logthis("<font color=red>CRITICAL: " 1622: ."Disconnect from $clientip ($hostid{$clientip})</font>"); 1623: 1624: 1625: # this exit is VERY important, otherwise the child will become 1626: # a producer of more and more children, forking yourself into 1627: # process death. 1628: exit; 1629: 1630: } 1631: 1632: 1633: # 1634: # Checks to see if the input roleput request was to set 1635: # an author role. If so, invokes the lchtmldir script to set 1636: # up a correct public_html 1637: # Parameters: 1638: # request - The request sent to the rolesput subchunk. 1639: # We're looking for /domain/_au 1640: # domain - The domain in which the user is having roles doctored. 1641: # user - Name of the user for which the role is being put. 1642: # authtype - The authentication type associated with the user. 1643: # 1644: sub ManagePermissions 1645: { 1646: my $request = shift; 1647: my $domain = shift; 1648: my $user = shift; 1649: my $authtype= shift; 1650: 1651: # See if the request is of the form /$domain/_au 1652: 1653: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... 1654: my $execdir = $perlvar{'lonDaemons'}; 1655: my $userhome= "/home/$user" ; 1656: Debug("system $execdir/lchtmldir $userhome $system $authtype"); 1657: system("$execdir/lchtmldir $userhome $user $authtype"); 1658: } 1659: } 1660: # 1661: # GetAuthType - Determines the authorization type of a user in a domain. 1662: 1663: # Returns the authorization type or nouser if there is no such user. 1664: # 1665: sub GetAuthType 1666: { 1667: my $domain = shift; 1668: my $user = shift; 1669: 1670: Debug("GetAuthType( $domain, $user ) \n"); 1671: my $proname = &propath($domain, $user); 1672: my $passwdfile = "$proname/passwd"; 1673: if( -e $passwdfile ) { 1674: my $pf = IO::File->new($passwdfile); 1675: my $realpassword = <$pf>; 1676: chomp($realpassword); 1677: Debug("Password info = $realpassword\n"); 1678: my ($authtype, $contentpwd) = split(/:/, $realpassword); 1679: Debug("Authtype = $authtype, content = $contentpwd\n"); 1680: my $availinfo = ''; 1681: if($authtype eq 'krb4' or $authtype eq 'krb5') { 1682: $availinfo = $contentpwd; 1683: } 1684: 1685: return "$authtype:$availinfo"; 1686: } 1687: else { 1688: Debug("Returning nouser"); 1689: return "nouser"; 1690: } 1691: } 1692: 1693: sub addline { 1694: my ($fname,$hostid,$ip,$newline)=@_; 1695: my $contents; 1696: my $found=0; 1697: my $expr='^'.$hostid.':'.$ip.':'; 1698: $expr =~ s/\./\\\./g; 1699: if ($sh=IO::File->new("$fname.subscription")) { 1700: while (my $subline=<$sh>) { 1701: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} 1702: } 1703: $sh->close(); 1704: } 1705: $sh=IO::File->new(">$fname.subscription"); 1706: if ($contents) { print $sh $contents; } 1707: if ($newline) { print $sh $newline; } 1708: $sh->close(); 1709: return $found; 1710: } 1711: 1712: sub getchat { 1713: my ($cdom,$cname)=@_; 1714: my %hash; 1715: my $proname=&propath($cdom,$cname); 1716: my @entries=(); 1717: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", 1718: &GDBM_READER(),0640)) { 1719: @entries=map { $_.':'.$hash{$_} } sort keys %hash; 1720: untie %hash; 1721: } 1722: return @entries; 1723: } 1724: 1725: sub chatadd { 1726: my ($cdom,$cname,$newchat)=@_; 1727: my %hash; 1728: my $proname=&propath($cdom,$cname); 1729: my @entries=(); 1730: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", 1731: &GDBM_WRCREAT(),0640)) { 1732: @entries=map { $_.':'.$hash{$_} } sort keys %hash; 1733: my $time=time; 1734: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); 1735: my ($thentime,$idnum)=split(/\_/,$lastid); 1736: my $newid=$time.'_000000'; 1737: if ($thentime==$time) { 1738: $idnum=~s/^0+//; 1739: $idnum++; 1740: $idnum=substr('000000'.$idnum,-6,6); 1741: $newid=$time.'_'.$idnum; 1742: } 1743: $hash{$newid}=$newchat; 1744: my $expired=$time-3600; 1745: foreach (keys %hash) { 1746: my ($thistime)=($_=~/(\d+)\_/); 1747: if ($thistime<$expired) { 1748: delete $hash{$_}; 1749: } 1750: } 1751: untie %hash; 1752: } 1753: } 1754: 1755: sub unsub { 1756: my ($fname,$clientip)=@_; 1757: my $result; 1758: if (unlink("$fname.$hostid{$clientip}")) { 1759: $result="ok\n"; 1760: } else { 1761: $result="not_subscribed\n"; 1762: } 1763: if (-e "$fname.subscription") { 1764: my $found=&addline($fname,$hostid{$clientip},$clientip,''); 1765: if ($found) { $result="ok\n"; } 1766: } else { 1767: if ($result != "ok\n") { $result="not_subscribed\n"; } 1768: } 1769: return $result; 1770: } 1771: 1772: sub currentversion { 1773: my $fname=shift; 1774: my $version=-1; 1775: my $ulsdir=''; 1776: if ($fname=~/^(.+)\/[^\/]+$/) { 1777: $ulsdir=$1; 1778: } 1779: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; 1780: $fname=~s/\.(\w+(?:\.meta)*)$/\.\(\\d\+\)\.$1\$/; 1781: 1782: if (-e $fname) { $version=1; } 1783: if (-e $ulsdir) { 1784: if(-d $ulsdir) { 1785: if (opendir(LSDIR,$ulsdir)) { 1786: while ($ulsfn=readdir(LSDIR)) { 1787: # see if this is a regular file (ignore links produced earlier) 1788: my $thisfile=$ulsdir.'/'.$ulsfn; 1789: unless (-l $thisfile) { 1790: if ($thisfile=~/$fname/) { 1791: if ($1>$version) { $version=$1; } 1792: } 1793: } 1794: } 1795: closedir(LSDIR); 1796: $version++; 1797: } 1798: } 1799: } 1800: return $version; 1801: } 1802: 1803: sub thisversion { 1804: my $fname=shift; 1805: my $version=-1; 1806: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { 1807: $version=$1; 1808: } 1809: return $version; 1810: } 1811: 1812: sub subscribe { 1813: my ($userinput,$clientip)=@_; 1814: my $result; 1815: my ($cmd,$fname)=split(/:/,$userinput); 1816: my $ownership=&ishome($fname); 1817: if ($ownership eq 'owner') { 1818: # explitly asking for the current version? 1819: unless (-e $fname) { 1820: my $currentversion=¤tversion($fname); 1821: if (&thisversion($fname)==$currentversion) { 1822: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { 1823: my $root=$1; 1824: my $extension=$2; 1825: symlink($root.'.'.$extension, 1826: $root.'.'.$currentversion.'.'.$extension); 1827: unless ($extension=~/\.meta$/) { 1828: symlink($root.'.'.$extension.'.meta', 1829: $root.'.'.$currentversion.'.'.$extension.'.meta'); 1830: } 1831: } 1832: } 1833: } 1834: if (-e $fname) { 1835: if (-d $fname) { 1836: $result="directory\n"; 1837: } else { 1838: if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} 1839: $now=time; 1840: my $found=&addline($fname,$hostid{$clientip},$clientip, 1841: "$hostid{$clientip}:$clientip:$now\n"); 1842: if ($found) { $result="$fname\n"; } 1843: # if they were subscribed to only meta data, delete that 1844: # subscription, when you subscribe to a file you also get 1845: # the metadata 1846: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } 1847: $fname=~s/\/home\/httpd\/html\/res/raw/; 1848: $fname="http://$thisserver/".$fname; 1849: $result="$fname\n"; 1850: } 1851: } else { 1852: $result="not_found\n"; 1853: } 1854: } else { 1855: $result="rejected\n"; 1856: } 1857: return $result; 1858: } 1859: 1860: sub make_passwd_file { 1861: my ($uname, $umode,$npass,$passfilename)=@_; 1862: my $result="ok\n"; 1863: if ($umode eq 'krb4' or $umode eq 'krb5') { 1864: { 1865: my $pf = IO::File->new(">$passfilename"); 1866: print $pf "$umode:$npass\n"; 1867: } 1868: } elsif ($umode eq 'internal') { 1869: my $salt=time; 1870: $salt=substr($salt,6,2); 1871: my $ncpass=crypt($npass,$salt); 1872: { 1873: &Debug("Creating internal auth"); 1874: my $pf = IO::File->new(">$passfilename"); 1875: print $pf "internal:$ncpass\n"; 1876: } 1877: } elsif ($umode eq 'localauth') { 1878: { 1879: my $pf = IO::File->new(">$passfilename"); 1880: print $pf "localauth:$npass\n"; 1881: } 1882: } elsif ($umode eq 'unix') { 1883: { 1884: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; 1885: { 1886: &Debug("Executing external: ".$execpath); 1887: &Debug("user = ".$uname.", Password =". $npass); 1888: my $se = IO::File->new("|$execpath > /home/www/lcuseradd.log"); 1889: print $se "$uname\n"; 1890: print $se "$npass\n"; 1891: print $se "$npass\n"; 1892: } 1893: my $useraddok = $?; 1894: if($useraddok > 0) { 1895: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); 1896: } 1897: my $pf = IO::File->new(">$passfilename"); 1898: print $pf "unix:\n"; 1899: } 1900: } elsif ($umode eq 'none') { 1901: { 1902: my $pf = IO::File->new(">$passfilename"); 1903: print $pf "none:\n"; 1904: } 1905: } else { 1906: $result="auth_mode_error\n"; 1907: } 1908: return $result; 1909: } 1910: 1911: # ----------------------------------- POD (plain old documentation, CPAN style) 1912: 1913: =head1 NAME 1914: 1915: lond - "LON Daemon" Server (port "LOND" 5663) 1916: 1917: =head1 SYNOPSIS 1918: 1919: Usage: B<lond> 1920: 1921: Should only be run as user=www. This is a command-line script which 1922: is invoked by B<loncron>. There is no expectation that a typical user 1923: will manually start B<lond> from the command-line. (In other words, 1924: DO NOT START B<lond> YOURSELF.) 1925: 1926: =head1 DESCRIPTION 1927: 1928: There are two characteristics associated with the running of B<lond>, 1929: PROCESS MANAGEMENT (starting, stopping, handling child processes) 1930: and SERVER-SIDE ACTIVITIES (password authentication, user creation, 1931: subscriptions, etc). These are described in two large 1932: sections below. 1933: 1934: B<PROCESS MANAGEMENT> 1935: 1936: Preforker - server who forks first. Runs as a daemon. HUPs. 1937: Uses IDEA encryption 1938: 1939: B<lond> forks off children processes that correspond to the other servers 1940: in the network. Management of these processes can be done at the 1941: parent process level or the child process level. 1942: 1943: B<logs/lond.log> is the location of log messages. 1944: 1945: The process management is now explained in terms of linux shell commands, 1946: subroutines internal to this code, and signal assignments: 1947: 1948: =over 4 1949: 1950: =item * 1951: 1952: PID is stored in B<logs/lond.pid> 1953: 1954: This is the process id number of the parent B<lond> process. 1955: 1956: =item * 1957: 1958: SIGTERM and SIGINT 1959: 1960: Parent signal assignment: 1961: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 1962: 1963: Child signal assignment: 1964: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) 1965: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber 1966: to restart a new child.) 1967: 1968: Command-line invocations: 1969: B<kill> B<-s> SIGTERM I<PID> 1970: B<kill> B<-s> SIGINT I<PID> 1971: 1972: Subroutine B<HUNTSMAN>: 1973: This is only invoked for the B<lond> parent I<PID>. 1974: This kills all the children, and then the parent. 1975: The B<lonc.pid> file is cleared. 1976: 1977: =item * 1978: 1979: SIGHUP 1980: 1981: Current bug: 1982: This signal can only be processed the first time 1983: on the parent process. Subsequent SIGHUP signals 1984: have no effect. 1985: 1986: Parent signal assignment: 1987: $SIG{HUP} = \&HUPSMAN; 1988: 1989: Child signal assignment: 1990: none (nothing happens) 1991: 1992: Command-line invocations: 1993: B<kill> B<-s> SIGHUP I<PID> 1994: 1995: Subroutine B<HUPSMAN>: 1996: This is only invoked for the B<lond> parent I<PID>, 1997: This kills all the children, and then the parent. 1998: The B<lond.pid> file is cleared. 1999: 2000: =item * 2001: 2002: SIGUSR1 2003: 2004: Parent signal assignment: 2005: $SIG{USR1} = \&USRMAN; 2006: 2007: Child signal assignment: 2008: $SIG{USR1}= \&logstatus; 2009: 2010: Command-line invocations: 2011: B<kill> B<-s> SIGUSR1 I<PID> 2012: 2013: Subroutine B<USRMAN>: 2014: When invoked for the B<lond> parent I<PID>, 2015: SIGUSR1 is sent to all the children, and the status of 2016: each connection is logged. 2017: 2018: =item * 2019: 2020: SIGCHLD 2021: 2022: Parent signal assignment: 2023: $SIG{CHLD} = \&REAPER; 2024: 2025: Child signal assignment: 2026: none 2027: 2028: Command-line invocations: 2029: B<kill> B<-s> SIGCHLD I<PID> 2030: 2031: Subroutine B<REAPER>: 2032: This is only invoked for the B<lond> parent I<PID>. 2033: Information pertaining to the child is removed. 2034: The socket port is cleaned up. 2035: 2036: =back 2037: 2038: B<SERVER-SIDE ACTIVITIES> 2039: 2040: Server-side information can be accepted in an encrypted or non-encrypted 2041: method. 2042: 2043: =over 4 2044: 2045: =item ping 2046: 2047: Query a client in the hosts.tab table; "Are you there?" 2048: 2049: =item pong 2050: 2051: Respond to a ping query. 2052: 2053: =item ekey 2054: 2055: Read in encrypted key, make cipher. Respond with a buildkey. 2056: 2057: =item load 2058: 2059: Respond with CPU load based on a computation upon /proc/loadavg. 2060: 2061: =item currentauth 2062: 2063: Reply with current authentication information (only over an 2064: encrypted channel). 2065: 2066: =item auth 2067: 2068: Only over an encrypted channel, reply as to whether a user's 2069: authentication information can be validated. 2070: 2071: =item passwd 2072: 2073: Allow for a password to be set. 2074: 2075: =item makeuser 2076: 2077: Make a user. 2078: 2079: =item passwd 2080: 2081: Allow for authentication mechanism and password to be changed. 2082: 2083: =item home 2084: 2085: Respond to a question "are you the home for a given user?" 2086: 2087: =item update 2088: 2089: Update contents of a subscribed resource. 2090: 2091: =item unsubscribe 2092: 2093: The server is unsubscribing from a resource. 2094: 2095: =item subscribe 2096: 2097: The server is subscribing to a resource. 2098: 2099: =item log 2100: 2101: Place in B<logs/lond.log> 2102: 2103: =item put 2104: 2105: stores hash in namespace 2106: 2107: =item rolesput 2108: 2109: put a role into a user's environment 2110: 2111: =item get 2112: 2113: returns hash with keys from array 2114: reference filled in from namespace 2115: 2116: =item eget 2117: 2118: returns hash with keys from array 2119: reference filled in from namesp (encrypts the return communication) 2120: 2121: =item rolesget 2122: 2123: get a role from a user's environment 2124: 2125: =item del 2126: 2127: deletes keys out of array from namespace 2128: 2129: =item keys 2130: 2131: returns namespace keys 2132: 2133: =item dump 2134: 2135: dumps the complete (or key matching regexp) namespace into a hash 2136: 2137: =item store 2138: 2139: stores hash permanently 2140: for this url; hashref needs to be given and should be a \%hashname; the 2141: remaining args aren't required and if they aren't passed or are '' they will 2142: be derived from the ENV 2143: 2144: =item restore 2145: 2146: returns a hash for a given url 2147: 2148: =item querysend 2149: 2150: Tells client about the lonsql process that has been launched in response 2151: to a sent query. 2152: 2153: =item queryreply 2154: 2155: Accept information from lonsql and make appropriate storage in temporary 2156: file space. 2157: 2158: =item idput 2159: 2160: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers 2161: for each student, defined perhaps by the institutional Registrar.) 2162: 2163: =item idget 2164: 2165: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers 2166: for each student, defined perhaps by the institutional Registrar.) 2167: 2168: =item tmpput 2169: 2170: Accept and store information in temporary space. 2171: 2172: =item tmpget 2173: 2174: Send along temporarily stored information. 2175: 2176: =item ls 2177: 2178: List part of a user's directory. 2179: 2180: =item Hanging up (exit or init) 2181: 2182: What to do when a client tells the server that they (the client) 2183: are leaving the network. 2184: 2185: =item unknown command 2186: 2187: If B<lond> is sent an unknown command (not in the list above), 2188: it replys to the client "unknown_cmd". 2189: 2190: =item UNKNOWN CLIENT 2191: 2192: If the anti-spoofing algorithm cannot verify the client, 2193: the client is rejected (with a "refused" message sent 2194: to the client, and the connection is closed. 2195: 2196: =back 2197: 2198: =head1 PREREQUISITES 2199: 2200: IO::Socket 2201: IO::File 2202: Apache::File 2203: Symbol 2204: POSIX 2205: Crypt::IDEA 2206: LWP::UserAgent() 2207: GDBM_File 2208: Authen::Krb4 2209: Authen::Krb5 2210: 2211: =head1 COREQUISITES 2212: 2213: =head1 OSNAMES 2214: 2215: linux 2216: 2217: =head1 SCRIPT CATEGORIES 2218: 2219: Server/Process 2220: 2221: =cut