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