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