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