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