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