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