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