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