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