Annotation of nsdl/bin/gatewayd, revision 1.1
1.1 ! harris41 1: #!/usr/bin/perl
! 2:
! 3: # gatewayd - "LON Daemon" Server (port "LOND" 5663)
! 4: #
! 5: # $Id$
! 6:
! 7: # This is derived from LON-CAPA's lond.
! 8:
! 9: # based on "Perl Cookbook" ISBN 1-56592-243-3
! 10: # preforker - server who forks first
! 11: # runs as a daemon
! 12: # HUPs
! 13: # uses IDEA encryption
! 14:
! 15: use lib '/home/httpd/lib/perl/';
! 16: use LONCAPA::Configuration;
! 17:
! 18: use IO::Socket;
! 19: use IO::File;
! 20: use Apache::File;
! 21: use Symbol;
! 22: use POSIX;
! 23: use Crypt::IDEA;
! 24: use LWP::UserAgent();
! 25: use GDBM_File;
! 26: use Authen::Krb4;
! 27: use lib '/home/httpd/lib/perl/';
! 28: use localauth;
! 29:
! 30: my $DEBUG = 0; # Non zero to enable debug log entries.
! 31:
! 32: my $status='';
! 33: my $lastlog='';
! 34:
! 35: # grabs exception and records it to log before exiting
! 36: sub catchexception {
! 37: my ($error)=@_;
! 38: $SIG{'QUIT'}='DEFAULT';
! 39: $SIG{__DIE__}='DEFAULT';
! 40: &logthis("<font color=red>CRITICAL: "
! 41: ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
! 42: ."a crash with this error msg->[$error]</font>");
! 43: &logthis('Famous last words: '.$status.' - '.$lastlog);
! 44: if ($client) { print $client "error: $error\n"; }
! 45: $server->close();
! 46: die($error);
! 47: }
! 48:
! 49: sub timeout {
! 50: &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
! 51: &catchexception('Timeout');
! 52: }
! 53: # -------------------------------- Set signal handlers to record abnormal exits
! 54:
! 55: $SIG{'QUIT'}=\&catchexception;
! 56: $SIG{__DIE__}=\&catchexception;
! 57:
! 58: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
! 59: &status("Read loncapa_apache.conf and loncapa.conf");
! 60: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
! 61: 'loncapa.conf');
! 62: my %perlvar=%{$perlvarref};
! 63: undef $perlvarref;
! 64:
! 65: # ----------------------------- Make sure this process is running from user=www
! 66: my $wwwid=getpwnam('www');
! 67: if ($wwwid!=$<) {
! 68: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
! 69: $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
! 70: system("echo 'User ID mismatch. lond must be run as user www.' |\
! 71: mailto $emailto -s '$subj' > /dev/null");
! 72: exit 1;
! 73: }
! 74:
! 75: # --------------------------------------------- Check if other instance running
! 76:
! 77: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
! 78:
! 79: if (-e $pidfile) {
! 80: my $lfh=IO::File->new("$pidfile");
! 81: my $pide=<$lfh>;
! 82: chomp($pide);
! 83: if (kill 0 => $pide) { die "already running"; }
! 84: }
! 85:
! 86: $PREFORK=4; # number of children to maintain, at least four spare
! 87:
! 88: # ------------------------------------------------------------- Read hosts file
! 89:
! 90: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
! 91:
! 92: while ($configline=<CONFIG>) {
! 93: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
! 94: chomp($ip); $ip=~s/\D+$//;
! 95: $hostid{$ip}=$id;
! 96: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
! 97: $PREFORK++;
! 98: }
! 99: close(CONFIG);
! 100:
! 101: # establish SERVER socket, bind and listen.
! 102: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
! 103: Type => SOCK_STREAM,
! 104: Proto => 'tcp',
! 105: Reuse => 1,
! 106: Listen => 10 )
! 107: or die "making socket: $@\n";
! 108:
! 109: # --------------------------------------------------------- Do global variables
! 110:
! 111: # global variables
! 112:
! 113: $MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should
! 114: # process
! 115: %children = (); # keys are current child process IDs
! 116: $children = 0; # current number of children
! 117:
! 118: sub REAPER { # takes care of dead children
! 119: $SIG{CHLD} = \&REAPER;
! 120: my $pid = wait;
! 121: if (defined($children{$pid})) {
! 122: &logthis("Child $pid died");
! 123: $children --;
! 124: delete $children{$pid};
! 125: } else {
! 126: &logthis("Unknown Child $pid died");
! 127: }
! 128: }
! 129:
! 130: sub HUNTSMAN { # signal handler for SIGINT
! 131: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
! 132: kill 'INT' => keys %children;
! 133: &logthis("Free socket: ".shutdown($server,2)); # free up socket
! 134: my $execdir=$perlvar{'lonDaemons'};
! 135: unlink("$execdir/logs/lond.pid");
! 136: &logthis("<font color=red>CRITICAL: Shutting down</font>");
! 137: exit; # clean up with dignity
! 138: }
! 139:
! 140: sub HUPSMAN { # signal handler for SIGHUP
! 141: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
! 142: kill 'INT' => keys %children;
! 143: &logthis("Free socket: ".shutdown($server,2)); # free up socket
! 144: &logthis("<font color=red>CRITICAL: Restarting</font>");
! 145: unlink("$execdir/logs/lond.pid");
! 146: my $execdir=$perlvar{'lonDaemons'};
! 147: exec("$execdir/lond"); # here we go again
! 148: }
! 149:
! 150: sub checkchildren {
! 151: &initnewstatus();
! 152: &logstatus();
! 153: &logthis('Going to check on the children');
! 154: $docdir=$perlvar{'lonDocRoot'};
! 155: foreach (sort keys %children) {
! 156: sleep 1;
! 157: unless (kill 'USR1' => $_) {
! 158: &logthis ('Child '.$_.' is dead');
! 159: &logstatus($$.' is dead');
! 160: }
! 161: }
! 162: sleep 5;
! 163: foreach (sort keys %children) {
! 164: unless (-e "$docdir/lon-status/londchld/$_.txt") {
! 165: &logthis('Child '.$_.' did not respond');
! 166: kill 9 => $_;
! 167: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
! 168: $subj="LON: $perlvar{'lonHostID'} killed lond process $_";
! 169: my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
! 170: $execdir=$perlvar{'lonDaemons'};
! 171: $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`
! 172: }
! 173: }
! 174: }
! 175:
! 176: # --------------------------------------------------------------------- Logging
! 177:
! 178: sub logthis {
! 179: my $message=shift;
! 180: my $execdir=$perlvar{'lonDaemons'};
! 181: my $fh=IO::File->new(">>$execdir/logs/lond.log");
! 182: my $now=time;
! 183: my $local=localtime($now);
! 184: $lastlog=$local.': '.$message;
! 185: print $fh "$local ($$): $message\n";
! 186: }
! 187:
! 188: # ------------------------- Conditional log if $DEBUG true.
! 189: sub Debug {
! 190: my $message = shift;
! 191: if($DEBUG) {
! 192: &logthis($message);
! 193: }
! 194: }
! 195: # ------------------------------------------------------------------ Log status
! 196:
! 197: sub logstatus {
! 198: my $docdir=$perlvar{'lonDocRoot'};
! 199: {
! 200: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
! 201: print $fh $$."\t".$status."\t".$lastlog."\n";
! 202: $fh->close();
! 203: }
! 204: {
! 205: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
! 206: print $fh $status."\n".$lastlog."\n".time;
! 207: $fh->close();
! 208: }
! 209: }
! 210:
! 211: sub initnewstatus {
! 212: my $docdir=$perlvar{'lonDocRoot'};
! 213: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
! 214: my $now=time;
! 215: my $local=localtime($now);
! 216: print $fh "LOND status $local - parent $$\n\n";
! 217: opendir(DIR,"$docdir/lon-status/londchld");
! 218: while ($filename=readdir(DIR)) {
! 219: unlink("$docdir/lon-status/londchld/$filename");
! 220: }
! 221: closedir(DIR);
! 222: }
! 223:
! 224: # -------------------------------------------------------------- Status setting
! 225:
! 226: sub status {
! 227: my $what=shift;
! 228: my $now=time;
! 229: my $local=localtime($now);
! 230: $status=$local.': '.$what;
! 231: }
! 232:
! 233: # -------------------------------------------------------- Escape Special Chars
! 234:
! 235: sub escape {
! 236: my $str=shift;
! 237: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
! 238: return $str;
! 239: }
! 240:
! 241: # ----------------------------------------------------- Un-Escape Special Chars
! 242:
! 243: sub unescape {
! 244: my $str=shift;
! 245: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
! 246: return $str;
! 247: }
! 248:
! 249: # ----------------------------------------------------------- Send USR1 to lonc
! 250:
! 251: sub reconlonc {
! 252: my $peerfile=shift;
! 253: &logthis("Trying to reconnect for $peerfile");
! 254: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
! 255: if (my $fh=IO::File->new("$loncfile")) {
! 256: my $loncpid=<$fh>;
! 257: chomp($loncpid);
! 258: if (kill 0 => $loncpid) {
! 259: &logthis("lonc at pid $loncpid responding, sending USR1");
! 260: kill USR1 => $loncpid;
! 261: sleep 5;
! 262: if (-e "$peerfile") { return; }
! 263: &logthis("$peerfile still not there, give it another try");
! 264: sleep 10;
! 265: if (-e "$peerfile") { return; }
! 266: &logthis(
! 267: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
! 268: } else {
! 269: &logthis(
! 270: "<font color=red>CRITICAL: "
! 271: ."lonc at pid $loncpid not responding, giving up</font>");
! 272: }
! 273: } else {
! 274: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
! 275: }
! 276: }
! 277:
! 278: # -------------------------------------------------- Non-critical communication
! 279:
! 280: sub subreply {
! 281: my ($cmd,$server)=@_;
! 282: my $peerfile="$perlvar{'lonSockDir'}/$server";
! 283: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
! 284: Type => SOCK_STREAM,
! 285: Timeout => 10)
! 286: or return "con_lost";
! 287: print $sclient "$cmd\n";
! 288: my $answer=<$sclient>;
! 289: chomp($answer);
! 290: if (!$answer) { $answer="con_lost"; }
! 291: return $answer;
! 292: }
! 293:
! 294: sub reply {
! 295: my ($cmd,$server)=@_;
! 296: my $answer;
! 297: if ($server ne $perlvar{'lonHostID'}) {
! 298: $answer=subreply($cmd,$server);
! 299: if ($answer eq 'con_lost') {
! 300: $answer=subreply("ping",$server);
! 301: if ($answer ne $server) {
! 302: &logthis("sub reply: answer != server");
! 303: &reconlonc("$perlvar{'lonSockDir'}/$server");
! 304: }
! 305: $answer=subreply($cmd,$server);
! 306: }
! 307: } else {
! 308: $answer='self_reply';
! 309: }
! 310: return $answer;
! 311: }
! 312:
! 313: # -------------------------------------------------------------- Talk to lonsql
! 314:
! 315: sub sqlreply {
! 316: my ($cmd)=@_;
! 317: my $answer=subsqlreply($cmd);
! 318: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
! 319: return $answer;
! 320: }
! 321:
! 322: sub subsqlreply {
! 323: my ($cmd)=@_;
! 324: my $unixsock="mysqlsock";
! 325: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
! 326: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
! 327: Type => SOCK_STREAM,
! 328: Timeout => 10)
! 329: or return "con_lost";
! 330: print $sclient "$cmd\n";
! 331: my $answer=<$sclient>;
! 332: chomp($answer);
! 333: if (!$answer) { $answer="con_lost"; }
! 334: return $answer;
! 335: }
! 336:
! 337: # -------------------------------------------- Return path to profile directory
! 338:
! 339: sub propath {
! 340: my ($udom,$uname)=@_;
! 341: $udom=~s/\W//g;
! 342: $uname=~s/\W//g;
! 343: my $subdir=$uname.'__';
! 344: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
! 345: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
! 346: return $proname;
! 347: }
! 348:
! 349: # --------------------------------------- Is this the home server of an author?
! 350:
! 351: sub ishome {
! 352: my $author=shift;
! 353: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
! 354: my ($udom,$uname)=split(/\//,$author);
! 355: my $proname=propath($udom,$uname);
! 356: if (-e $proname) {
! 357: return 'owner';
! 358: } else {
! 359: return 'not_owner';
! 360: }
! 361: }
! 362:
! 363: # ======================================================= Continue main program
! 364: # ---------------------------------------------------- Fork once and dissociate
! 365:
! 366: $fpid=fork;
! 367: exit if $fpid;
! 368: die "Couldn't fork: $!" unless defined ($fpid);
! 369:
! 370: POSIX::setsid() or die "Can't start new session: $!";
! 371:
! 372: # ------------------------------------------------------- Write our PID on disk
! 373:
! 374: $execdir=$perlvar{'lonDaemons'};
! 375: open (PIDSAVE,">$execdir/logs/lond.pid");
! 376: print PIDSAVE "$$\n";
! 377: close(PIDSAVE);
! 378: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
! 379: &status('Starting');
! 380:
! 381: # ------------------------------------------------------- Now we are on our own
! 382:
! 383: # Fork off our children.
! 384: for (1 .. $PREFORK) {
! 385: make_new_child();
! 386: }
! 387:
! 388: # ----------------------------------------------------- Install signal handlers
! 389:
! 390: &status('Forked children');
! 391:
! 392: $SIG{CHLD} = \&REAPER;
! 393: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
! 394: $SIG{HUP} = \&HUPSMAN;
! 395: $SIG{USR1} = \&checkchildren;
! 396:
! 397: # And maintain the population.
! 398: while (1) {
! 399: &status('Sleeping');
! 400: sleep; # wait for a signal (i.e., child's death)
! 401: &logthis('Woke up');
! 402: &status('Woke up');
! 403: for ($i = $children; $i < $PREFORK; $i++) {
! 404: make_new_child(); # top up the child pool
! 405: }
! 406: }
! 407:
! 408: sub make_new_child {
! 409: my $pid;
! 410: my $cipher;
! 411: my $sigset;
! 412: &logthis("Attempting to start child");
! 413: # block signal for fork
! 414: $sigset = POSIX::SigSet->new(SIGINT);
! 415: sigprocmask(SIG_BLOCK, $sigset)
! 416: or die "Can't block SIGINT for fork: $!\n";
! 417:
! 418: die "fork: $!" unless defined ($pid = fork);
! 419:
! 420: if ($pid) {
! 421: # Parent records the child's birth and returns.
! 422: sigprocmask(SIG_UNBLOCK, $sigset)
! 423: or die "Can't unblock SIGINT for fork: $!\n";
! 424: $children{$pid} = 1;
! 425: $children++;
! 426: &status('Started child '.$pid);
! 427: return;
! 428: } else {
! 429: # Child can *not* return from this subroutine.
! 430: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
! 431: $SIG{USR1}= \&logstatus;
! 432: $SIG{ALRM}= \&timeout;
! 433: $lastlog='Forked ';
! 434: $status='Forked';
! 435:
! 436: # unblock signals
! 437: sigprocmask(SIG_UNBLOCK, $sigset)
! 438: or die "Can't unblock SIGINT for fork: $!\n";
! 439:
! 440: $tmpsnum=0;
! 441:
! 442: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
! 443: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
! 444: &status('Idle, waiting for connection');
! 445: $client = $server->accept() or last;
! 446: &status('Accepted connection');
! 447: # =============================================================================
! 448: # do something with the connection
! 449: # -----------------------------------------------------------------------------
! 450: # see if we know client and check for spoof IP by challenge
! 451: my $caller=getpeername($client);
! 452: my ($port,$iaddr)=unpack_sockaddr_in($caller);
! 453: my $clientip=inet_ntoa($iaddr);
! 454: my $clientrec=($hostid{$clientip} ne undef);
! 455: &logthis(
! 456: "<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>"
! 457: );
! 458: &status("Connecting $clientip ($hostid{$clientip})");
! 459: my $clientok;
! 460: if ($clientrec) {
! 461: &status("Waiting for init from $clientip ($hostid{$clientip})");
! 462: my $remotereq=<$client>;
! 463: $remotereq=~s/\W//g;
! 464: if ($remotereq eq 'init') {
! 465: my $challenge="$$".time;
! 466: print $client "$challenge\n";
! 467: &status(
! 468: "Waiting for challenge reply from $clientip ($hostid{$clientip})");
! 469: $remotereq=<$client>;
! 470: $remotereq=~s/\W//g;
! 471: if ($challenge eq $remotereq) {
! 472: $clientok=1;
! 473: print $client "ok\n";
! 474: } else {
! 475: &logthis(
! 476: "<font color=blue>WARNING: $clientip did not reply challenge</font>");
! 477: &status('No challenge reply '.$clientip);
! 478: }
! 479: } else {
! 480: &logthis(
! 481: "<font color=blue>WARNING: "
! 482: ."$clientip failed to initialize: >$remotereq< </font>");
! 483: &status('No init '.$clientip);
! 484: }
! 485: } else {
! 486: &logthis(
! 487: "<font color=blue>WARNING: Unknown client $clientip</font>");
! 488: &status('Hung up on '.$clientip);
! 489: }
! 490: if ($clientok) {
! 491: # ---------------- New known client connecting, could mean machine online again
! 492:
! 493: &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
! 494: &logthis(
! 495: "<font color=green>Established connection: $hostid{$clientip}</font>");
! 496: &status('Will listen to '.$hostid{$clientip});
! 497: # ------------------------------------------------------------ Process requests
! 498: while (my $userinput=<$client>) {
! 499: chomp($userinput);
! 500: Debug("Request = $userinput\n");
! 501: &status('Processing '.$hostid{$clientip}.': '.$userinput);
! 502: my $wasenc=0;
! 503: alarm(120);
! 504: # ------------------------------------------------------------ See if encrypted
! 505: if ($userinput =~ /^enc/) {
! 506: if ($cipher) {
! 507: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
! 508: $userinput='';
! 509: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
! 510: $userinput.=
! 511: $cipher->decrypt(
! 512: pack("H16",substr($encinput,$encidx,16))
! 513: );
! 514: }
! 515: $userinput=substr($userinput,0,$cmdlength);
! 516: $wasenc=1;
! 517: }
! 518: }
! 519:
! 520: # ------------------------------------------------------------- Normal commands
! 521: # ------------------------------------------------------------------------ ping
! 522: if ($userinput =~ /^ping/) {
! 523: print $client "$perlvar{'lonHostID'}\n";
! 524: # ------------------------------------------------------------------------ pong
! 525: } elsif ($userinput =~ /^pong/) {
! 526: $reply=reply("ping",$hostid{$clientip});
! 527: print $client "$perlvar{'lonHostID'}:$reply\n";
! 528: # ------------------------------------------------------------------------ ekey
! 529: } elsif ($userinput =~ /^ekey/) {
! 530: my $buildkey=time.$$.int(rand 100000);
! 531: $buildkey=~tr/1-6/A-F/;
! 532: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
! 533: my $key=$perlvar{'lonHostID'}.$hostid{$clientip};
! 534: $key=~tr/a-z/A-Z/;
! 535: $key=~tr/G-P/0-9/;
! 536: $key=~tr/Q-Z/0-9/;
! 537: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
! 538: $key=substr($key,0,32);
! 539: my $cipherkey=pack("H32",$key);
! 540: $cipher=new IDEA $cipherkey;
! 541: print $client "$buildkey\n";
! 542: # ------------------------------------------------------------------------ load
! 543: } elsif ($userinput =~ /^load/) {
! 544: my $loadavg;
! 545: {
! 546: my $loadfile=IO::File->new('/proc/loadavg');
! 547: $loadavg=<$loadfile>;
! 548: }
! 549: $loadavg =~ s/\s.*//g;
! 550: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
! 551: print $client "$loadpercent\n";
! 552: # ----------------------------------------------------------------- currentauth
! 553: } elsif ($userinput =~ /^currentauth/) {
! 554: if ($wasenc==1) {
! 555: my ($cmd,$udom,$uname)=split(/:/,$userinput);
! 556: my $result = GetAuthType($udom, $uname);
! 557: if($result eq "nouser") {
! 558: print $client "unknown_user\n";
! 559: }
! 560: else {
! 561: print $client "$result\n"
! 562: }
! 563: } else {
! 564: print $client "refused\n";
! 565: }
! 566: # ------------------------------------------------------------------------ auth
! 567: } elsif ($userinput =~ /^auth/) {
! 568: if ($wasenc==1) {
! 569: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
! 570: chomp($upass);
! 571: $upass=unescape($upass);
! 572: my $proname=propath($udom,$uname);
! 573: my $passfilename="$proname/passwd";
! 574: if (-e $passfilename) {
! 575: my $pf = IO::File->new($passfilename);
! 576: my $realpasswd=<$pf>;
! 577: chomp($realpasswd);
! 578: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
! 579: my $pwdcorrect=0;
! 580: if ($howpwd eq 'internal') {
! 581: $pwdcorrect=
! 582: (crypt($upass,$contentpwd) eq $contentpwd);
! 583: } elsif ($howpwd eq 'unix') {
! 584: $contentpwd=(getpwnam($uname))[1];
! 585: my $pwauth_path="/usr/local/sbin/pwauth";
! 586: unless ($contentpwd eq 'x') {
! 587: $pwdcorrect=
! 588: (crypt($upass,$contentpwd) eq $contentpwd);
! 589: }
! 590: elsif (-e $pwauth_path) {
! 591: open PWAUTH, "|$pwauth_path" or
! 592: die "Cannot invoke authentication";
! 593: print PWAUTH "$uname\n$upass\n";
! 594: close PWAUTH;
! 595: $pwdcorrect=!$?;
! 596: }
! 597: } elsif ($howpwd eq 'krb4') {
! 598: $null=pack("C",0);
! 599: unless ($upass=~/$null/) {
! 600: $pwdcorrect=(
! 601: Authen::Krb4::get_pw_in_tkt($uname,"",
! 602: $contentpwd,'krbtgt',$contentpwd,1,
! 603: $upass) == 0);
! 604: } else { $pwdcorrect=0; }
! 605: } elsif ($howpwd eq 'localauth') {
! 606: $pwdcorrect=&localauth::localauth($uname,$upass,
! 607: $contentpwd);
! 608: }
! 609: if ($pwdcorrect) {
! 610: print $client "authorized\n";
! 611: } else {
! 612: print $client "non_authorized\n";
! 613: }
! 614: } else {
! 615: print $client "unknown_user\n";
! 616: }
! 617: } else {
! 618: print $client "refused\n";
! 619: }
! 620: # ---------------------------------------------------------------------- passwd
! 621: } elsif ($userinput =~ /^passwd/) {
! 622: if ($wasenc==1) {
! 623: my
! 624: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
! 625: chomp($npass);
! 626: $upass=&unescape($upass);
! 627: $npass=&unescape($npass);
! 628: &logthis("Trying to change password for $uname");
! 629: my $proname=propath($udom,$uname);
! 630: my $passfilename="$proname/passwd";
! 631: if (-e $passfilename) {
! 632: my $realpasswd;
! 633: { my $pf = IO::File->new($passfilename);
! 634: $realpasswd=<$pf>; }
! 635: chomp($realpasswd);
! 636: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
! 637: if ($howpwd eq 'internal') {
! 638: if (crypt($upass,$contentpwd) eq $contentpwd) {
! 639: my $salt=time;
! 640: $salt=substr($salt,6,2);
! 641: my $ncpass=crypt($npass,$salt);
! 642: { my $pf = IO::File->new(">$passfilename");
! 643: print $pf "internal:$ncpass\n"; }
! 644: &logthis("Result of password change for $uname: pwchange_success");
! 645: print $client "ok\n";
! 646: } else {
! 647: print $client "non_authorized\n";
! 648: }
! 649: } elsif ($howpwd eq 'unix') {
! 650: # Unix means we have to access /etc/password
! 651: # one way or another.
! 652: # First: Make sure the current password is
! 653: # correct
! 654: $contentpwd=(getpwnam($uname))[1];
! 655: my $pwdcorrect = "0";
! 656: my $pwauth_path="/usr/local/sbin/pwauth";
! 657: unless ($contentpwd eq 'x') {
! 658: $pwdcorrect=
! 659: (crypt($upass,$contentpwd) eq $contentpwd);
! 660: } elsif (-e $pwauth_path) {
! 661: open PWAUTH, "|$pwauth_path" or
! 662: die "Cannot invoke authentication";
! 663: print PWAUTH "$uname\n$upass\n";
! 664: close PWAUTH;
! 665: $pwdcorrect=!$?;
! 666: }
! 667: if ($pwdcorrect) {
! 668: my $execdir=$perlvar{'lonDaemons'};
! 669: my $pf = IO::File->new("|$execdir/lcpasswd");
! 670: print $pf "$uname\n$npass\n$npass\n";
! 671: close $pf;
! 672: my $result = ($?>0 ? 'pwchange_failure'
! 673: : 'ok');
! 674: &logthis("Result of password change for $uname: $result");
! 675: print $client "$result\n";
! 676: } else {
! 677: print $client "non_authorized\n";
! 678: }
! 679: } else {
! 680: print $client "auth_mode_error\n";
! 681: }
! 682: } else {
! 683: print $client "unknown_user\n";
! 684: }
! 685: } else {
! 686: print $client "refused\n";
! 687: }
! 688: # -------------------------------------------------------------------- makeuser
! 689: } elsif ($userinput =~ /^makeuser/) {
! 690: Debug("Make user received");
! 691: my $oldumask=umask(0077);
! 692: if ($wasenc==1) {
! 693: my
! 694: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
! 695: &Debug("cmd =".$cmd." $udom =".$udom.
! 696: " uname=".$uname);
! 697: chomp($npass);
! 698: $npass=&unescape($npass);
! 699: my $proname=propath($udom,$uname);
! 700: my $passfilename="$proname/passwd";
! 701: &Debug("Password file created will be:".
! 702: $passfilename);
! 703: if (-e $passfilename) {
! 704: print $client "already_exists\n";
! 705: } elsif ($udom ne $perlvar{'lonDefDomain'}) {
! 706: print $client "not_right_domain\n";
! 707: } else {
! 708: @fpparts=split(/\//,$proname);
! 709: $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
! 710: $fperror='';
! 711: for ($i=3;$i<=$#fpparts;$i++) {
! 712: $fpnow.='/'.$fpparts[$i];
! 713: unless (-e $fpnow) {
! 714: unless (mkdir($fpnow,0777)) {
! 715: $fperror="error:$!";
! 716: }
! 717: }
! 718: }
! 719: unless ($fperror) {
! 720: if ($umode eq 'krb4') {
! 721: {
! 722: my $pf = IO::File->new(">$passfilename");
! 723: print $pf "krb4:$npass\n";
! 724: }
! 725: print $client "ok\n";
! 726: } elsif ($umode eq 'internal') {
! 727: my $salt=time;
! 728: $salt=substr($salt,6,2);
! 729: my $ncpass=crypt($npass,$salt);
! 730: {
! 731: &Debug("Creating internal auth");
! 732: my $pf = IO::File->new(">$passfilename");
! 733: print $pf "internal:$ncpass\n";
! 734: }
! 735: print $client "ok\n";
! 736: } elsif ($umode eq 'localauth') {
! 737: {
! 738: my $pf = IO::File->new(">$passfilename");
! 739: print $pf "localauth:$npass\n";
! 740: }
! 741: print $client "ok\n";
! 742: } elsif ($umode eq 'unix') {
! 743: {
! 744: my $execpath="$perlvar{'lonDaemons'}/".
! 745: "lcuseradd";
! 746: {
! 747: &Debug("Executing external: ".
! 748: $execpath);
! 749: my $se = IO::File->new("|$execpath");
! 750: print $se "$uname\n";
! 751: print $se "$npass\n";
! 752: print $se "$npass\n";
! 753: }
! 754: my $pf = IO::File->new(">$passfilename");
! 755: print $pf "unix:\n";
! 756: }
! 757: print $client "ok\n";
! 758: } elsif ($umode eq 'none') {
! 759: {
! 760: my $pf = IO::File->new(">$passfilename");
! 761: print $pf "none:\n";
! 762: }
! 763: print $client "ok\n";
! 764: } else {
! 765: print $client "auth_mode_error\n";
! 766: }
! 767: } else {
! 768: print $client "$fperror\n";
! 769: }
! 770: }
! 771: } else {
! 772: print $client "refused\n";
! 773: }
! 774: umask($oldumask);
! 775: # -------------------------------------------------------------- changeuserauth
! 776: } elsif ($userinput =~ /^changeuserauth/) {
! 777: &Debug("Changing authorization");
! 778: if ($wasenc==1) {
! 779: my
! 780: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
! 781: chomp($npass);
! 782: &Debug("cmd = ".$cmd." domain= ".$udom.
! 783: "uname =".$uname." umode= ".$umode);
! 784: $npass=&unescape($npass);
! 785: my $proname=propath($udom,$uname);
! 786: my $passfilename="$proname/passwd";
! 787: if ($udom ne $perlvar{'lonDefDomain'}) {
! 788: print $client "not_right_domain\n";
! 789: } else {
! 790: if ($umode eq 'krb4') {
! 791: {
! 792: my $pf = IO::File->new(">$passfilename");
! 793: print $pf "krb4:$npass\n";
! 794: }
! 795: print $client "ok\n";
! 796: } elsif ($umode eq 'internal') {
! 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: print $pf "internal:$ncpass\n";
! 803: }
! 804: print $client "ok\n";
! 805: } elsif ($umode eq 'localauth') {
! 806: {
! 807: my $pf = IO::File->new(">$passfilename");
! 808: print $pf "localauth:$npass\n";
! 809: }
! 810: print $client "ok\n";
! 811: } elsif ($umode eq 'unix') {
! 812: {
! 813: my $execpath="$perlvar{'lonDaemons'}/".
! 814: "lcuseradd";
! 815: {
! 816: my $se = IO::File->new("|$execpath");
! 817: print $se "$uname\n";
! 818: print $se "$npass\n";
! 819: print $se "$npass\n";
! 820: }
! 821: my $pf = IO::File->new(">$passfilename");
! 822: print $pf "unix:\n";
! 823: }
! 824: print $client "ok\n";
! 825: } elsif ($umode eq 'none') {
! 826: {
! 827: my $pf = IO::File->new(">$passfilename");
! 828: print $pf "none:\n";
! 829: }
! 830: print $client "ok\n";
! 831: } else {
! 832: print $client "auth_mode_error\n";
! 833: }
! 834: }
! 835: } else {
! 836: print $client "refused\n";
! 837: }
! 838: # ------------------------------------------------------------------------ home
! 839: } elsif ($userinput =~ /^home/) {
! 840: my ($cmd,$udom,$uname)=split(/:/,$userinput);
! 841: chomp($uname);
! 842: my $proname=propath($udom,$uname);
! 843: if (-e $proname) {
! 844: print $client "found\n";
! 845: } else {
! 846: print $client "not_found\n";
! 847: }
! 848: # ---------------------------------------------------------------------- update
! 849: } elsif ($userinput =~ /^update/) {
! 850: my ($cmd,$fname)=split(/:/,$userinput);
! 851: my $ownership=ishome($fname);
! 852: if ($ownership eq 'not_owner') {
! 853: if (-e $fname) {
! 854: my ($dev,$ino,$mode,$nlink,
! 855: $uid,$gid,$rdev,$size,
! 856: $atime,$mtime,$ctime,
! 857: $blksize,$blocks)=stat($fname);
! 858: $now=time;
! 859: $since=$now-$atime;
! 860: if ($since>$perlvar{'lonExpire'}) {
! 861: $reply=
! 862: reply("unsub:$fname","$hostid{$clientip}");
! 863: unlink("$fname");
! 864: } else {
! 865: my $transname="$fname.in.transfer";
! 866: my $remoteurl=
! 867: reply("sub:$fname","$hostid{$clientip}");
! 868: my $response;
! 869: {
! 870: my $ua=new LWP::UserAgent;
! 871: my $request=new HTTP::Request('GET',"$remoteurl");
! 872: $response=$ua->request($request,$transname);
! 873: }
! 874: if ($response->is_error()) {
! 875: unlink($transname);
! 876: my $message=$response->status_line;
! 877: &logthis(
! 878: "LWP GET: $message for $fname ($remoteurl)");
! 879: } else {
! 880: if ($remoteurl!~/\.meta$/) {
! 881: my $ua=new LWP::UserAgent;
! 882: my $mrequest=
! 883: new HTTP::Request('GET',$remoteurl.'.meta');
! 884: my $mresponse=
! 885: $ua->request($mrequest,$fname.'.meta');
! 886: if ($mresponse->is_error()) {
! 887: unlink($fname.'.meta');
! 888: }
! 889: }
! 890: rename($transname,$fname);
! 891: }
! 892: }
! 893: print $client "ok\n";
! 894: } else {
! 895: print $client "not_found\n";
! 896: }
! 897: } else {
! 898: print $client "rejected\n";
! 899: }
! 900: # ----------------------------------------------------------------- unsubscribe
! 901: } elsif ($userinput =~ /^unsub/) {
! 902: my ($cmd,$fname)=split(/:/,$userinput);
! 903: if (-e $fname) {
! 904: if (unlink("$fname.$hostid{$clientip}")) {
! 905: print $client "ok\n";
! 906: } else {
! 907: print $client "not_subscribed\n";
! 908: }
! 909: } else {
! 910: print $client "not_found\n";
! 911: }
! 912: # ------------------------------------------------------------------- subscribe
! 913: } elsif ($userinput =~ /^sub/) {
! 914: my ($cmd,$fname)=split(/:/,$userinput);
! 915: my $ownership=ishome($fname);
! 916: if ($ownership eq 'owner') {
! 917: if (-e $fname) {
! 918: if (-d $fname) {
! 919: print $client "directory\n";
! 920: } else {
! 921: $now=time;
! 922: {
! 923: my $sh;
! 924: if ($sh=
! 925: IO::File->new(">$fname.$hostid{$clientip}")) {
! 926: print $sh "$clientip:$now\n";
! 927: }
! 928: }
! 929: unless ($fname=~/\.meta$/) {
! 930: unlink("$fname.meta.$hostid{$clientip}");
! 931: }
! 932: $fname=~s/\/home\/httpd\/html\/res/raw/;
! 933: $fname="http://$thisserver/".$fname;
! 934: print $client "$fname\n";
! 935: }
! 936: } else {
! 937: print $client "not_found\n";
! 938: }
! 939: } else {
! 940: print $client "rejected\n";
! 941: }
! 942: # ------------------------------------------------------------------------- log
! 943: } elsif ($userinput =~ /^log/) {
! 944: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
! 945: chomp($what);
! 946: my $proname=propath($udom,$uname);
! 947: my $now=time;
! 948: {
! 949: my $hfh;
! 950: if ($hfh=IO::File->new(">>$proname/activity.log")) {
! 951: print $hfh "$now:$hostid{$clientip}:$what\n";
! 952: print $client "ok\n";
! 953: } else {
! 954: print $client "error:$!\n";
! 955: }
! 956: }
! 957: # ------------------------------------------------------------------------- put
! 958: } elsif ($userinput =~ /^put/) {
! 959: my ($cmd,$udom,$uname,$namespace,$what)
! 960: =split(/:/,$userinput);
! 961: $namespace=~s/\//\_/g;
! 962: $namespace=~s/\W//g;
! 963: if ($namespace ne 'roles') {
! 964: chomp($what);
! 965: my $proname=propath($udom,$uname);
! 966: my $now=time;
! 967: unless ($namespace=~/^nohist\_/) {
! 968: my $hfh;
! 969: if (
! 970: $hfh=IO::File->new(">>$proname/$namespace.hist")
! 971: ) { print $hfh "P:$now:$what\n"; }
! 972: }
! 973: my @pairs=split(/\&/,$what);
! 974: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
! 975: foreach $pair (@pairs) {
! 976: ($key,$value)=split(/=/,$pair);
! 977: $hash{$key}=$value;
! 978: }
! 979: if (untie(%hash)) {
! 980: print $client "ok\n";
! 981: } else {
! 982: print $client "error:$!\n";
! 983: }
! 984: } else {
! 985: print $client "error:$!\n";
! 986: }
! 987: } else {
! 988: print $client "refused\n";
! 989: }
! 990: # -------------------------------------------------------------------- rolesput
! 991: } elsif ($userinput =~ /^rolesput/) {
! 992: &Debug("rolesput");
! 993: if ($wasenc==1) {
! 994: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
! 995: =split(/:/,$userinput);
! 996: &Debug("cmd = ".$cmd." exedom= ".$exedom.
! 997: "user = ".$exeuser." udom=".$udom.
! 998: "what = ".$what);
! 999: my $namespace='roles';
! 1000: chomp($what);
! 1001: my $proname=propath($udom,$uname);
! 1002: my $now=time;
! 1003: {
! 1004: my $hfh;
! 1005: if (
! 1006: $hfh=IO::File->new(">>$proname/$namespace.hist")
! 1007: ) {
! 1008: print $hfh "P:$now:$exedom:$exeuser:$what\n";
! 1009: }
! 1010: }
! 1011: my @pairs=split(/\&/,$what);
! 1012: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
! 1013: foreach $pair (@pairs) {
! 1014: ($key,$value)=split(/=/,$pair);
! 1015: &ManagePermissions($key, $udom, $uname,
! 1016: &GetAuthType( $udom,
! 1017: $uname));
! 1018: $hash{$key}=$value;
! 1019:
! 1020: }
! 1021: if (untie(%hash)) {
! 1022: print $client "ok\n";
! 1023: } else {
! 1024: print $client "error:$!\n";
! 1025: }
! 1026: } else {
! 1027: print $client "error:$!\n";
! 1028: }
! 1029: } else {
! 1030: print $client "refused\n";
! 1031: }
! 1032: # ------------------------------------------------------------------------- get
! 1033: } elsif ($userinput =~ /^get/) {
! 1034: my ($cmd,$udom,$uname,$namespace,$what)
! 1035: =split(/:/,$userinput);
! 1036: $namespace=~s/\//\_/g;
! 1037: $namespace=~s/\W//g;
! 1038: chomp($what);
! 1039: my @queries=split(/\&/,$what);
! 1040: my $proname=propath($udom,$uname);
! 1041: my $qresult='';
! 1042: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
! 1043: for ($i=0;$i<=$#queries;$i++) {
! 1044: $qresult.="$hash{$queries[$i]}&";
! 1045: }
! 1046: if (untie(%hash)) {
! 1047: $qresult=~s/\&$//;
! 1048: print $client "$qresult\n";
! 1049: } else {
! 1050: print $client "error:$!\n";
! 1051: }
! 1052: } else {
! 1053: print $client "error:$!\n";
! 1054: }
! 1055: # ------------------------------------------------------------------------ eget
! 1056: } elsif ($userinput =~ /^eget/) {
! 1057: my ($cmd,$udom,$uname,$namespace,$what)
! 1058: =split(/:/,$userinput);
! 1059: $namespace=~s/\//\_/g;
! 1060: $namespace=~s/\W//g;
! 1061: chomp($what);
! 1062: my @queries=split(/\&/,$what);
! 1063: my $proname=propath($udom,$uname);
! 1064: my $qresult='';
! 1065: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
! 1066: for ($i=0;$i<=$#queries;$i++) {
! 1067: $qresult.="$hash{$queries[$i]}&";
! 1068: }
! 1069: if (untie(%hash)) {
! 1070: $qresult=~s/\&$//;
! 1071: if ($cipher) {
! 1072: my $cmdlength=length($qresult);
! 1073: $qresult.=" ";
! 1074: my $encqresult='';
! 1075: for
! 1076: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
! 1077: $encqresult.=
! 1078: unpack("H16",
! 1079: $cipher->encrypt(substr($qresult,$encidx,8)));
! 1080: }
! 1081: print $client "enc:$cmdlength:$encqresult\n";
! 1082: } else {
! 1083: print $client "error:no_key\n";
! 1084: }
! 1085: } else {
! 1086: print $client "error:$!\n";
! 1087: }
! 1088: } else {
! 1089: print $client "error:$!\n";
! 1090: }
! 1091: # ------------------------------------------------------------------------- del
! 1092: } elsif ($userinput =~ /^del/) {
! 1093: my ($cmd,$udom,$uname,$namespace,$what)
! 1094: =split(/:/,$userinput);
! 1095: $namespace=~s/\//\_/g;
! 1096: $namespace=~s/\W//g;
! 1097: chomp($what);
! 1098: my $proname=propath($udom,$uname);
! 1099: my $now=time;
! 1100: unless ($namespace=~/^nohist\_/) {
! 1101: my $hfh;
! 1102: if (
! 1103: $hfh=IO::File->new(">>$proname/$namespace.hist")
! 1104: ) { print $hfh "D:$now:$what\n"; }
! 1105: }
! 1106: my @keys=split(/\&/,$what);
! 1107: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
! 1108: foreach $key (@keys) {
! 1109: delete($hash{$key});
! 1110: }
! 1111: if (untie(%hash)) {
! 1112: print $client "ok\n";
! 1113: } else {
! 1114: print $client "error:$!\n";
! 1115: }
! 1116: } else {
! 1117: print $client "error:$!\n";
! 1118: }
! 1119: # ------------------------------------------------------------------------ keys
! 1120: } elsif ($userinput =~ /^keys/) {
! 1121: my ($cmd,$udom,$uname,$namespace)
! 1122: =split(/:/,$userinput);
! 1123: $namespace=~s/\//\_/g;
! 1124: $namespace=~s/\W//g;
! 1125: my $proname=propath($udom,$uname);
! 1126: my $qresult='';
! 1127: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
! 1128: foreach $key (keys %hash) {
! 1129: $qresult.="$key&";
! 1130: }
! 1131: if (untie(%hash)) {
! 1132: $qresult=~s/\&$//;
! 1133: print $client "$qresult\n";
! 1134: } else {
! 1135: print $client "error:$!\n";
! 1136: }
! 1137: } else {
! 1138: print $client "error:$!\n";
! 1139: }
! 1140: # ------------------------------------------------------------------------ dump
! 1141: } elsif ($userinput =~ /^dump/) {
! 1142: my ($cmd,$udom,$uname,$namespace,$regexp)
! 1143: =split(/:/,$userinput);
! 1144: $namespace=~s/\//\_/g;
! 1145: $namespace=~s/\W//g;
! 1146: if (defined($regexp)) {
! 1147: $regexp=&unescape($regexp);
! 1148: } else {
! 1149: $regexp='.';
! 1150: }
! 1151: my $proname=propath($udom,$uname);
! 1152: my $qresult='';
! 1153: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
! 1154: foreach $key (keys %hash) {
! 1155: if (eval('$key=~/$regexp/')) {
! 1156: $qresult.="$key=$hash{$key}&";
! 1157: }
! 1158: }
! 1159: if (untie(%hash)) {
! 1160: $qresult=~s/\&$//;
! 1161: print $client "$qresult\n";
! 1162: } else {
! 1163: print $client "error:$!\n";
! 1164: }
! 1165: } else {
! 1166: print $client "error:$!\n";
! 1167: }
! 1168: # ----------------------------------------------------------------------- store
! 1169: } elsif ($userinput =~ /^store/) {
! 1170: my ($cmd,$udom,$uname,$namespace,$rid,$what)
! 1171: =split(/:/,$userinput);
! 1172: $namespace=~s/\//\_/g;
! 1173: $namespace=~s/\W//g;
! 1174: if ($namespace ne 'roles') {
! 1175: chomp($what);
! 1176: my $proname=propath($udom,$uname);
! 1177: my $now=time;
! 1178: unless ($namespace=~/^nohist\_/) {
! 1179: my $hfh;
! 1180: if (
! 1181: $hfh=IO::File->new(">>$proname/$namespace.hist")
! 1182: ) { print $hfh "P:$now:$rid:$what\n"; }
! 1183: }
! 1184: my @pairs=split(/\&/,$what);
! 1185:
! 1186: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
! 1187: my @previouskeys=split(/&/,$hash{"keys:$rid"});
! 1188: my $key;
! 1189: $hash{"version:$rid"}++;
! 1190: my $version=$hash{"version:$rid"};
! 1191: my $allkeys='';
! 1192: foreach $pair (@pairs) {
! 1193: ($key,$value)=split(/=/,$pair);
! 1194: $allkeys.=$key.':';
! 1195: $hash{"$version:$rid:$key"}=$value;
! 1196: }
! 1197: $hash{"$version:$rid:timestamp"}=$now;
! 1198: $allkeys.='timestamp';
! 1199: $hash{"$version:keys:$rid"}=$allkeys;
! 1200: if (untie(%hash)) {
! 1201: print $client "ok\n";
! 1202: } else {
! 1203: print $client "error:$!\n";
! 1204: }
! 1205: } else {
! 1206: print $client "error:$!\n";
! 1207: }
! 1208: } else {
! 1209: print $client "refused\n";
! 1210: }
! 1211: # --------------------------------------------------------------------- restore
! 1212: } elsif ($userinput =~ /^restore/) {
! 1213: my ($cmd,$udom,$uname,$namespace,$rid)
! 1214: =split(/:/,$userinput);
! 1215: $namespace=~s/\//\_/g;
! 1216: $namespace=~s/\W//g;
! 1217: chomp($rid);
! 1218: my $proname=propath($udom,$uname);
! 1219: my $qresult='';
! 1220: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
! 1221: my $version=$hash{"version:$rid"};
! 1222: $qresult.="version=$version&";
! 1223: my $scope;
! 1224: for ($scope=1;$scope<=$version;$scope++) {
! 1225: my $vkeys=$hash{"$scope:keys:$rid"};
! 1226: my @keys=split(/:/,$vkeys);
! 1227: my $key;
! 1228: $qresult.="$scope:keys=$vkeys&";
! 1229: foreach $key (@keys) {
! 1230: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
! 1231: }
! 1232: }
! 1233: if (untie(%hash)) {
! 1234: $qresult=~s/\&$//;
! 1235: print $client "$qresult\n";
! 1236: } else {
! 1237: print $client "error:$!\n";
! 1238: }
! 1239: } else {
! 1240: print $client "error:$!\n";
! 1241: }
! 1242: # ------------------------------------------------------------------- querysend
! 1243: } elsif ($userinput =~ /^querysend/) {
! 1244: my ($cmd,$query,
! 1245: $custom,$customshow)=split(/:/,$userinput);
! 1246: $query=~s/\n*$//g;
! 1247: unless ($custom or $customshow) {
! 1248: print $client "".
! 1249: sqlreply("$hostid{$clientip}\&$query")."\n";
! 1250: }
! 1251: else {
! 1252: print $client "".
! 1253: sqlreply("$hostid{$clientip}\&$query".
! 1254: "\&$custom"."\&$customshow")."\n";
! 1255: }
! 1256: # ------------------------------------------------------------------ queryreply
! 1257: } elsif ($userinput =~ /^queryreply/) {
! 1258: my ($cmd,$id,$reply)=split(/:/,$userinput);
! 1259: my $store;
! 1260: my $execdir=$perlvar{'lonDaemons'};
! 1261: if ($store=IO::File->new(">$execdir/tmp/$id")) {
! 1262: $reply=~s/\&/\n/g;
! 1263: print $store $reply;
! 1264: close $store;
! 1265: my $store2=IO::File->new(">$execdir/tmp/$id.end");
! 1266: print $store2 "done\n";
! 1267: close $store2;
! 1268: print $client "ok\n";
! 1269: }
! 1270: else {
! 1271: print $client "error:$!\n";
! 1272: }
! 1273: # ----------------------------------------------------------------------- idput
! 1274: } elsif ($userinput =~ /^idput/) {
! 1275: my ($cmd,$udom,$what)=split(/:/,$userinput);
! 1276: chomp($what);
! 1277: $udom=~s/\W//g;
! 1278: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
! 1279: my $now=time;
! 1280: {
! 1281: my $hfh;
! 1282: if (
! 1283: $hfh=IO::File->new(">>$proname.hist")
! 1284: ) { print $hfh "P:$now:$what\n"; }
! 1285: }
! 1286: my @pairs=split(/\&/,$what);
! 1287: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {
! 1288: foreach $pair (@pairs) {
! 1289: ($key,$value)=split(/=/,$pair);
! 1290: $hash{$key}=$value;
! 1291: }
! 1292: if (untie(%hash)) {
! 1293: print $client "ok\n";
! 1294: } else {
! 1295: print $client "error:$!\n";
! 1296: }
! 1297: } else {
! 1298: print $client "error:$!\n";
! 1299: }
! 1300: # ----------------------------------------------------------------------- idget
! 1301: } elsif ($userinput =~ /^idget/) {
! 1302: my ($cmd,$udom,$what)=split(/:/,$userinput);
! 1303: chomp($what);
! 1304: $udom=~s/\W//g;
! 1305: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
! 1306: my @queries=split(/\&/,$what);
! 1307: my $qresult='';
! 1308: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
! 1309: for ($i=0;$i<=$#queries;$i++) {
! 1310: $qresult.="$hash{$queries[$i]}&";
! 1311: }
! 1312: if (untie(%hash)) {
! 1313: $qresult=~s/\&$//;
! 1314: print $client "$qresult\n";
! 1315: } else {
! 1316: print $client "error:$!\n";
! 1317: }
! 1318: } else {
! 1319: print $client "error:$!\n";
! 1320: }
! 1321: # ---------------------------------------------------------------------- tmpput
! 1322: } elsif ($userinput =~ /^tmpput/) {
! 1323: my ($cmd,$what)=split(/:/,$userinput);
! 1324: my $store;
! 1325: $tmpsnum++;
! 1326: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
! 1327: $id=~s/\W/\_/g;
! 1328: $what=~s/\n//g;
! 1329: my $execdir=$perlvar{'lonDaemons'};
! 1330: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
! 1331: print $store $what;
! 1332: close $store;
! 1333: print $client "$id\n";
! 1334: }
! 1335: else {
! 1336: print $client "error:$!\n";
! 1337: }
! 1338:
! 1339: # ---------------------------------------------------------------------- tmpget
! 1340: } elsif ($userinput =~ /^tmpget/) {
! 1341: my ($cmd,$id)=split(/:/,$userinput);
! 1342: chomp($id);
! 1343: $id=~s/\W/\_/g;
! 1344: my $store;
! 1345: my $execdir=$perlvar{'lonDaemons'};
! 1346: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
! 1347: my $reply=<$store>;
! 1348: print $client "$reply\n";
! 1349: close $store;
! 1350: }
! 1351: else {
! 1352: print $client "error:$!\n";
! 1353: }
! 1354:
! 1355: # -------------------------------------------------------------------------- ls
! 1356: } elsif ($userinput =~ /^ls/) {
! 1357: my ($cmd,$ulsdir)=split(/:/,$userinput);
! 1358: my $ulsout='';
! 1359: my $ulsfn;
! 1360: if (-e $ulsdir) {
! 1361: if (opendir(LSDIR,$ulsdir)) {
! 1362: while ($ulsfn=readdir(LSDIR)) {
! 1363: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
! 1364: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
! 1365: }
! 1366: closedir(LSDIR);
! 1367: }
! 1368: } else {
! 1369: $ulsout='no_such_dir';
! 1370: }
! 1371: if ($ulsout eq '') { $ulsout='empty'; }
! 1372: print $client "$ulsout\n";
! 1373: # ------------------------------------------------------------------ Hanging up
! 1374: } elsif (($userinput =~ /^exit/) ||
! 1375: ($userinput =~ /^init/)) {
! 1376: &logthis(
! 1377: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
! 1378: print $client "bye\n";
! 1379: $client->close();
! 1380: last;
! 1381: # ------------------------------------------------------------- unknown command
! 1382: } else {
! 1383: # unknown command
! 1384: print $client "unknown_cmd\n";
! 1385: }
! 1386: # -------------------------------------------------------------------- complete
! 1387: alarm(0);
! 1388: &status('Listening to '.$hostid{$clientip});
! 1389: }
! 1390: # --------------------------------------------- client unknown or fishy, refuse
! 1391: } else {
! 1392: print $client "refused\n";
! 1393: $client->close();
! 1394: &logthis("<font color=blue>WARNING: "
! 1395: ."Rejected client $clientip, closing connection</font>");
! 1396: }
! 1397: }
! 1398:
! 1399: # =============================================================================
! 1400:
! 1401: &logthis("<font color=red>CRITICAL: "
! 1402: ."Disconnect from $clientip ($hostid{$clientip})</font>");
! 1403: # tidy up gracefully and finish
! 1404:
! 1405: $server->close();
! 1406:
! 1407: # this exit is VERY important, otherwise the child will become
! 1408: # a producer of more and more children, forking yourself into
! 1409: # process death.
! 1410: exit;
! 1411: }
! 1412: }
! 1413:
! 1414:
! 1415: #
! 1416: # Checks to see if the input roleput request was to set
! 1417: # an author role. If so, invokes the lchtmldir script to set
! 1418: # up a correct public_html
! 1419: # Parameters:
! 1420: # request - The request sent to the rolesput subchunk.
! 1421: # We're looking for /domain/_au
! 1422: # domain - The domain in which the user is having roles doctored.
! 1423: # user - Name of the user for which the role is being put.
! 1424: # authtype - The authentication type associated with the user.
! 1425: #
! 1426: sub ManagePermissions
! 1427: {
! 1428: my $request = shift;
! 1429: my $domain = shift;
! 1430: my $user = shift;
! 1431: my $authtype= shift;
! 1432:
! 1433: # See if the request is of the form /$domain/_au
! 1434:
! 1435: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
! 1436: my $execdir = $perlvar{'lonDaemons'};
! 1437: my $userhome= "/home/$user" ;
! 1438: Debug("system $execdir/lchtmldir $userhome $system $authtype");
! 1439: system("$execdir/lchtmldir $userhome $user $authtype");
! 1440: }
! 1441: }
! 1442: #
! 1443: # GetAuthType - Determines the authorization type of a user in a domain.
! 1444:
! 1445: # Returns the authorization type or nouser if there is no such user.
! 1446: #
! 1447: sub GetAuthType
! 1448: {
! 1449: my $domain = shift;
! 1450: my $user = shift;
! 1451:
! 1452: Debug("GetAuthType( $domain, $user ) \n");
! 1453: my $proname = &propath($domain, $user);
! 1454: my $passwdfile = "$proname/passwd";
! 1455: if( -e $passwdfile ) {
! 1456: my $pf = IO::File->new($passwdfile);
! 1457: my $realpassword = <$pf>;
! 1458: chomp($realpassword);
! 1459: Debug("Password info = $realpassword\n");
! 1460: my ($authtype, $contentpwd) = split(/:/, $realpassword);
! 1461: Debug("Authtype = $authtype, content = $contentpwd\n");
! 1462: my $availinfo = '';
! 1463: if($authtype eq 'krb4') {
! 1464: $availinfo = $contentpwd;
! 1465: }
! 1466:
! 1467: return "$authtype:$availinfo";
! 1468: }
! 1469: else {
! 1470: Debug("Returning nouser");
! 1471: return "nouser";
! 1472: }
! 1473:
! 1474: }
! 1475:
! 1476: # ----------------------------------- POD (plain old documentation, CPAN style)
! 1477:
! 1478: =head1 NAME
! 1479:
! 1480: lond - "LON Daemon" Server (port "LOND" 5663)
! 1481:
! 1482: =head1 SYNOPSIS
! 1483:
! 1484: Usage: B<gatewayd>
! 1485:
! 1486: Should only be run as user=www. This is a command-line script which
! 1487: is invoked by B<loncron>. There is no expectation that a typical user
! 1488: will manually start B<lond> from the command-line. (In other words,
! 1489: DO NOT START B<lond> YOURSELF.)
! 1490:
! 1491: =head1 DESCRIPTION
! 1492:
! 1493: There are two characteristics associated with the running of B<lond>,
! 1494: PROCESS MANAGEMENT (starting, stopping, handling child processes)
! 1495: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
! 1496: subscriptions, etc). These are described in two large
! 1497: sections below.
! 1498:
! 1499: B<PROCESS MANAGEMENT>
! 1500:
! 1501: Preforker - server who forks first. Runs as a daemon. HUPs.
! 1502: Uses IDEA encryption
! 1503:
! 1504: B<lond> forks off children processes that correspond to the other servers
! 1505: in the network. Management of these processes can be done at the
! 1506: parent process level or the child process level.
! 1507:
! 1508: B<logs/lond.log> is the location of log messages.
! 1509:
! 1510: The process management is now explained in terms of linux shell commands,
! 1511: subroutines internal to this code, and signal assignments:
! 1512:
! 1513: =over 4
! 1514:
! 1515: =item *
! 1516:
! 1517: PID is stored in B<logs/lond.pid>
! 1518:
! 1519: This is the process id number of the parent B<lond> process.
! 1520:
! 1521: =item *
! 1522:
! 1523: SIGTERM and SIGINT
! 1524:
! 1525: Parent signal assignment:
! 1526: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
! 1527:
! 1528: Child signal assignment:
! 1529: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
! 1530: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
! 1531: to restart a new child.)
! 1532:
! 1533: Command-line invocations:
! 1534: B<kill> B<-s> SIGTERM I<PID>
! 1535: B<kill> B<-s> SIGINT I<PID>
! 1536:
! 1537: Subroutine B<HUNTSMAN>:
! 1538: This is only invoked for the B<lond> parent I<PID>.
! 1539: This kills all the children, and then the parent.
! 1540: The B<lonc.pid> file is cleared.
! 1541:
! 1542: =item *
! 1543:
! 1544: SIGHUP
! 1545:
! 1546: Current bug:
! 1547: This signal can only be processed the first time
! 1548: on the parent process. Subsequent SIGHUP signals
! 1549: have no effect.
! 1550:
! 1551: Parent signal assignment:
! 1552: $SIG{HUP} = \&HUPSMAN;
! 1553:
! 1554: Child signal assignment:
! 1555: none (nothing happens)
! 1556:
! 1557: Command-line invocations:
! 1558: B<kill> B<-s> SIGHUP I<PID>
! 1559:
! 1560: Subroutine B<HUPSMAN>:
! 1561: This is only invoked for the B<lond> parent I<PID>,
! 1562: This kills all the children, and then the parent.
! 1563: The B<lond.pid> file is cleared.
! 1564:
! 1565: =item *
! 1566:
! 1567: SIGUSR1
! 1568:
! 1569: Parent signal assignment:
! 1570: $SIG{USR1} = \&USRMAN;
! 1571:
! 1572: Child signal assignment:
! 1573: $SIG{USR1}= \&logstatus;
! 1574:
! 1575: Command-line invocations:
! 1576: B<kill> B<-s> SIGUSR1 I<PID>
! 1577:
! 1578: Subroutine B<USRMAN>:
! 1579: When invoked for the B<lond> parent I<PID>,
! 1580: SIGUSR1 is sent to all the children, and the status of
! 1581: each connection is logged.
! 1582:
! 1583: =item *
! 1584:
! 1585: SIGCHLD
! 1586:
! 1587: Parent signal assignment:
! 1588: $SIG{CHLD} = \&REAPER;
! 1589:
! 1590: Child signal assignment:
! 1591: none
! 1592:
! 1593: Command-line invocations:
! 1594: B<kill> B<-s> SIGCHLD I<PID>
! 1595:
! 1596: Subroutine B<REAPER>:
! 1597: This is only invoked for the B<lond> parent I<PID>.
! 1598: Information pertaining to the child is removed.
! 1599: The socket port is cleaned up.
! 1600:
! 1601: =back
! 1602:
! 1603: B<SERVER-SIDE ACTIVITIES>
! 1604:
! 1605: Server-side information can be accepted in an encrypted or non-encrypted
! 1606: method.
! 1607:
! 1608: =over 4
! 1609:
! 1610: =item ping
! 1611:
! 1612: Query a client in the hosts.tab table; "Are you there?"
! 1613:
! 1614: =item pong
! 1615:
! 1616: Respond to a ping query.
! 1617:
! 1618: =item ekey
! 1619:
! 1620: Read in encrypted key, make cipher. Respond with a buildkey.
! 1621:
! 1622: =item load
! 1623:
! 1624: Respond with CPU load based on a computation upon /proc/loadavg.
! 1625:
! 1626: =item currentauth
! 1627:
! 1628: Reply with current authentication information (only over an
! 1629: encrypted channel).
! 1630:
! 1631: =item auth
! 1632:
! 1633: Only over an encrypted channel, reply as to whether a user's
! 1634: authentication information can be validated.
! 1635:
! 1636: =item passwd
! 1637:
! 1638: Allow for a password to be set.
! 1639:
! 1640: =item makeuser
! 1641:
! 1642: Make a user.
! 1643:
! 1644: =item passwd
! 1645:
! 1646: Allow for authentication mechanism and password to be changed.
! 1647:
! 1648: =item home
! 1649:
! 1650: Respond to a question "are you the home for a given user?"
! 1651:
! 1652: =item update
! 1653:
! 1654: Update contents of a subscribed resource.
! 1655:
! 1656: =item unsubscribe
! 1657:
! 1658: The server is unsubscribing from a resource.
! 1659:
! 1660: =item subscribe
! 1661:
! 1662: The server is subscribing to a resource.
! 1663:
! 1664: =item log
! 1665:
! 1666: Place in B<logs/lond.log>
! 1667:
! 1668: =item put
! 1669:
! 1670: stores hash in namespace
! 1671:
! 1672: =item rolesput
! 1673:
! 1674: put a role into a user's environment
! 1675:
! 1676: =item get
! 1677:
! 1678: returns hash with keys from array
! 1679: reference filled in from namespace
! 1680:
! 1681: =item eget
! 1682:
! 1683: returns hash with keys from array
! 1684: reference filled in from namesp (encrypts the return communication)
! 1685:
! 1686: =item rolesget
! 1687:
! 1688: get a role from a user's environment
! 1689:
! 1690: =item del
! 1691:
! 1692: deletes keys out of array from namespace
! 1693:
! 1694: =item keys
! 1695:
! 1696: returns namespace keys
! 1697:
! 1698: =item dump
! 1699:
! 1700: dumps the complete (or key matching regexp) namespace into a hash
! 1701:
! 1702: =item store
! 1703:
! 1704: stores hash permanently
! 1705: for this url; hashref needs to be given and should be a \%hashname; the
! 1706: remaining args aren't required and if they aren't passed or are '' they will
! 1707: be derived from the ENV
! 1708:
! 1709: =item restore
! 1710:
! 1711: returns a hash for a given url
! 1712:
! 1713: =item querysend
! 1714:
! 1715: Tells client about the lonsql process that has been launched in response
! 1716: to a sent query.
! 1717:
! 1718: =item queryreply
! 1719:
! 1720: Accept information from lonsql and make appropriate storage in temporary
! 1721: file space.
! 1722:
! 1723: =item idput
! 1724:
! 1725: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
! 1726: for each student, defined perhaps by the institutional Registrar.)
! 1727:
! 1728: =item idget
! 1729:
! 1730: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
! 1731: for each student, defined perhaps by the institutional Registrar.)
! 1732:
! 1733: =item tmpput
! 1734:
! 1735: Accept and store information in temporary space.
! 1736:
! 1737: =item tmpget
! 1738:
! 1739: Send along temporarily stored information.
! 1740:
! 1741: =item ls
! 1742:
! 1743: List part of a user's directory.
! 1744:
! 1745: =item Hanging up (exit or init)
! 1746:
! 1747: What to do when a client tells the server that they (the client)
! 1748: are leaving the network.
! 1749:
! 1750: =item unknown command
! 1751:
! 1752: If B<lond> is sent an unknown command (not in the list above),
! 1753: it replys to the client "unknown_cmd".
! 1754:
! 1755: =item UNKNOWN CLIENT
! 1756:
! 1757: If the anti-spoofing algorithm cannot verify the client,
! 1758: the client is rejected (with a "refused" message sent
! 1759: to the client, and the connection is closed.
! 1760:
! 1761: =back
! 1762:
! 1763: =head1 PREREQUISITES
! 1764:
! 1765: IO::Socket
! 1766: IO::File
! 1767: Apache::File
! 1768: Symbol
! 1769: POSIX
! 1770: Crypt::IDEA
! 1771: LWP::UserAgent()
! 1772: GDBM_File
! 1773: Authen::Krb4
! 1774:
! 1775: =head1 COREQUISITES
! 1776:
! 1777: =head1 OSNAMES
! 1778:
! 1779: linux
! 1780:
! 1781: =head1 SCRIPT CATEGORIES
! 1782:
! 1783: Server/Process
! 1784:
! 1785: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to gatewayd CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / nsdl / bin