1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
4: #
5: # $Id: lond,v 1.195 2004/06/17 10:15:46 foxr Exp $
6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
13: # the Free Software Foundation; either version 2 of the License, or
14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
27:
28:
29: # http://www.lon-capa.org/
30: #
31:
32: use strict;
33: use lib '/home/httpd/lib/perl/';
34: use LONCAPA::Configuration;
35:
36: use IO::Socket;
37: use IO::File;
38: #use Apache::File;
39: use Symbol;
40: use POSIX;
41: use Crypt::IDEA;
42: use LWP::UserAgent();
43: use GDBM_File;
44: use Authen::Krb4;
45: use Authen::Krb5;
46: use lib '/home/httpd/lib/perl/';
47: use localauth;
48: use localenroll;
49: use File::Copy;
50: use LONCAPA::ConfigFileEdit;
51: use LONCAPA::lonlocal;
52: use LONCAPA::lonssl;
53:
54: my $DEBUG = 0; # Non zero to enable debug log entries.
55:
56: my $status='';
57: my $lastlog='';
58:
59: my $VERSION='$Revision: 1.195 $'; #' stupid emacs
60: my $remoteVERSION;
61: my $currenthostid;
62: my $currentdomainid;
63:
64: my $client;
65: my $clientip; # IP address of client.
66: my $clientdns; # DNS name of client.
67: my $clientname; # LonCAPA name of client.
68:
69: my $server;
70: my $thisserver; # DNS of us.
71:
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: #
78:
79: my $ConnectionType;
80:
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.
85:
86: my %managers; # Ip -> manager names
87:
88: my %perlvar; # Will have the apache conf defined perl vars.
89:
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");
107:
108:
109: # The array below are lcuseradd error strings.:
110:
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");
126:
127:
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:
300: #
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: }
316:
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: }
329:
330:
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:
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
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: #
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: }
379: }
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:
391: return isManager;
392: }
393: #
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 {
405:
406: my ($oldfile, $newfile) = @_;
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: }
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:
465: foreach my $line (split(/\n/,$contents)) {
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) {
470: my $ip = gethostbyname($name);
471: my $ipnew = inet_ntoa($ip);
472: $ip = $ipnew;
473: # Reconstruct the host line and append to adjusted:
474:
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";
480:
481: } else { # Not me, pass unmodified.
482: $adjusted .= $line."\n";
483: }
484: } else { # Blank or comment never re-written.
485: $adjusted .= $line."\n"; # Pass blanks and comments as is.
486: }
487: }
488: return $adjusted;
489: }
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 {
506:
507: my ($Filename, $Contents) = @_;
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: }
530:
531:
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;
555:
556: }
557: #
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:
586:
587: my $tablefile = ConfigFileFromSelector($filename);
588: if(! (defined $tablefile)) {
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/;
598: if(!CopyFile($tablefile, $backupfile)) {
599: &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
600: return "error:$!";
601: }
602: &logthis('<font color="green"> Pushfile: backed up '
603: .$tablefile." to $backupfile</font>");
604:
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:
615: # Install the new file:
616:
617: if(!InstallFile($tablefile, $contents)) {
618: &logthis('<font color="red"> Pushfile: unable to install '
619: .$tablefile." $! </font>");
620: return "error:$!";
621: }
622: else {
623: &logthis('<font color="green"> Installed new '.$tablefile
624: ."</font>");
625:
626: }
627:
628:
629: # Indicate success:
630:
631: return "ok";
632:
633: }
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:
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);
659: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
660: if($process eq 'lonc') {
661: $processpidfile = $processpidfile."lonc.pid";
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);
670: } elsif ($process eq 'lond') {
671: logthis('<font color="red"> Reinitializing self (lond) </font>');
672: &UpdateHosts; # Lond is us!!
673: } else {
674: &logthis('<font color="yellow" Invalid reinit request for '.$process
675: ."</font>");
676: return "error:Invalid process identifier $process";
677: }
678: return 'ok';
679: }
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).
686: #
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: }
712: } elsif ($command eq "replace") {
713: #
714: # key and newline:
715: #
716: if (($key eq "") || ($newline eq "")) {
717: return 0;
718: } else {
719: return 1;
720: }
721: } elsif ($command eq "append") {
722: if (($key ne "") && ($newline eq "")) {
723: return 1;
724: } else {
725: return 0;
726: }
727: } else {
728: return 0; # Invalid command.
729: }
730: return 0; # Should not get here!!!
731: }
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 {
746:
747: my ($directive, $editor) = @_;
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 {
831:
832: my ($filename, $editor) = @_;
833:
834: CopyFile ($filename, $filename.".old");
835:
836: my $contents = $editor->Get(); # Get the contents of the file.
837:
838: InstallFile($filename, $contents);
839: }
840: #
841: #
842: # Called to edit a configuration table file
843: # Parameters:
844: # request - The entire command/request sent by lonc or lonManage
845: # Return:
846: # The reply to send to the client.
847: #
848: sub EditFile {
849: my $request = shift;
850:
851: # Split the command into it's pieces: edit:filetype:script
852:
853: my ($request, $filetype, $script) = split(/:/, $request,3); # : in script
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.
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: }
875:
876: # Execute the edit operation.
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);
885:
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);
898:
899: return "ok\n";
900: }
901: #
902: # Convert an error return code from lcpasswd to a string value.
903: #
904: sub lcpasswdstrerror {
905: my $ErrorCode = shift;
906: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
907: return "lcpasswd Unrecognized error return value ".$ErrorCode;
908: } else {
909: return $passwderrors[$ErrorCode];
910: }
911: }
912:
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 {
921: return $adderrors[$ErrorCode];
922: }
923: }
924:
925: # grabs exception and records it to log before exiting
926: sub catchexception {
927: my ($error)=@_;
928: $SIG{'QUIT'}='DEFAULT';
929: $SIG{__DIE__}='DEFAULT';
930: &status("Catching exception");
931: &logthis("<font color='red'>CRITICAL: "
932: ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
933: ."a crash with this error msg->[$error]</font>");
934: &logthis('Famous last words: '.$status.' - '.$lastlog);
935: if ($client) { print $client "error: $error\n"; }
936: $server->close();
937: die($error);
938: }
939:
940: sub timeout {
941: &status("Handling Timeout");
942: &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
943: &catchexception('Timeout');
944: }
945: # -------------------------------- Set signal handlers to record abnormal exits
946:
947: $SIG{'QUIT'}=\&catchexception;
948: $SIG{__DIE__}=\&catchexception;
949:
950: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
951: &status("Read loncapa.conf and loncapa_apache.conf");
952: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
953: %perlvar=%{$perlvarref};
954: undef $perlvarref;
955:
956: # ----------------------------- Make sure this process is running from user=www
957: my $wwwid=getpwnam('www');
958: if ($wwwid!=$<) {
959: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
960: my $subj="LON: $currenthostid User ID mismatch";
961: system("echo 'User ID mismatch. lond must be run as user www.' |\
962: mailto $emailto -s '$subj' > /dev/null");
963: exit 1;
964: }
965:
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);
974: if (kill 0 => $pide) { die "already running"; }
975: }
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 )
987: or die "making socket: $@\n";
988:
989: # --------------------------------------------------------- Do global variables
990:
991: # global variables
992:
993: my %children = (); # keys are current child process IDs
994:
995: sub REAPER { # takes care of dead children
996: $SIG{CHLD} = \&REAPER;
997: &status("Handling child death");
998: my $pid;
999: do {
1000: $pid = waitpid(-1,&WNOHANG());
1001: if (defined($children{$pid})) {
1002: &logthis("Child $pid died");
1003: delete($children{$pid});
1004: } elsif ($pid > 0) {
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: }
1014: }
1015: &status("Finished Handling child death");
1016: }
1017:
1018: sub HUNTSMAN { # signal handler for SIGINT
1019: &status("Killing children (INT)");
1020: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
1021: kill 'INT' => keys %children;
1022: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1023: my $execdir=$perlvar{'lonDaemons'};
1024: unlink("$execdir/logs/lond.pid");
1025: &logthis("<font color='red'>CRITICAL: Shutting down</font>");
1026: &status("Done killing children");
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
1032: &status("Killing children for restart (HUP)");
1033: kill 'INT' => keys %children;
1034: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1035: &logthis("<font color='red'>CRITICAL: Restarting</font>");
1036: my $execdir=$perlvar{'lonDaemons'};
1037: unlink("$execdir/logs/lond.pid");
1038: &status("Restarting self (HUP)");
1039: exec("$execdir/lond"); # here we go again
1040: }
1041:
1042: #
1043: # Kill off hashes that describe the host table prior to re-reading it.
1044: # Hashes affected are:
1045: # %hostid, %hostdom %hostip %hostdns.
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: }
1057: foreach my $key (keys %hostdns) {
1058: delete $hostdns{$key};
1059: }
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";
1070: my $myloncapaname = $perlvar{'lonHostID'};
1071: Debug("My loncapa name is : $myloncapaname");
1072: while (my $configline=<CONFIG>) {
1073: if (!($configline =~ /^\s*\#/)) {
1074: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
1075: chomp($ip); $ip=~s/\D+$//;
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: }
1085: }
1086: }
1087: close(CONFIG);
1088: }
1089: #
1090: # Reload the Apache daemon's state.
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.
1093: #
1094: sub ReloadApache {
1095: my $execdir = $perlvar{'lonDaemons'};
1096: my $script = $execdir."/apachereload";
1097: system($script);
1098: }
1099:
1100: #
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 {
1111: &status("Reload hosts.tab");
1112: logthis('<font color="blue"> Updating connections </font>');
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}) {
1127: logthis('<font color="blue"> UpdateHosts killing child '
1128: ." $child for ip $childip </font>");
1129: kill('INT', $child);
1130: } else {
1131: logthis('<font color="green"> keeping child for ip '
1132: ." $childip (pid=$child) </font>");
1133: }
1134: }
1135: ReloadApache;
1136: &status("Finished reloading hosts.tab");
1137: }
1138:
1139:
1140: sub checkchildren {
1141: &status("Checking on the children (sending signals)");
1142: &initnewstatus();
1143: &logstatus();
1144: &logthis('Going to check on the children');
1145: my $docdir=$perlvar{'lonDocRoot'};
1146: foreach (sort keys %children) {
1147: sleep 1;
1148: unless (kill 'USR1' => $_) {
1149: &logthis ('Child '.$_.' is dead');
1150: &logstatus($$.' is dead');
1151: }
1152: }
1153: sleep 5;
1154: $SIG{ALRM} = sub { die "timeout" };
1155: $SIG{__DIE__} = 'DEFAULT';
1156: &status("Checking on the children (waiting for reports)");
1157: foreach (sort keys %children) {
1158: unless (-e "$docdir/lon-status/londchld/$_.txt") {
1159: eval {
1160: alarm(300);
1161: &logthis('Child '.$_.' did not respond');
1162: kill 9 => $_;
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.$_`;
1168: alarm(0);
1169: }
1170: }
1171: }
1172: $SIG{ALRM} = 'DEFAULT';
1173: $SIG{__DIE__} = \&catchexception;
1174: &status("Finished checking children");
1175: }
1176:
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);
1185: $lastlog=$local.': '.$message;
1186: print $fh "$local ($$): $message\n";
1187: }
1188:
1189: # ------------------------- Conditional log if $DEBUG true.
1190: sub Debug {
1191: my $message = shift;
1192: if($DEBUG) {
1193: &logthis($message);
1194: }
1195: }
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 {
1206:
1207: my ($fd, $reply, $request) = @_;
1208:
1209: print $fd $reply;
1210: Debug("Request was $request Reply was $reply");
1211:
1212: }
1213: # ------------------------------------------------------------------ Log status
1214:
1215: sub logstatus {
1216: &status("Doing logging");
1217: my $docdir=$perlvar{'lonDocRoot'};
1218: {
1219: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
1220: print $fh $$."\t".$clientname."\t".$currenthostid."\t"
1221: .$status."\t".$lastlog."\n";
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");
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";
1239: opendir(DIR,"$docdir/lon-status/londchld");
1240: while (my $filename=readdir(DIR)) {
1241: unlink("$docdir/lon-status/londchld/$filename");
1242: }
1243: closedir(DIR);
1244: }
1245:
1246: # -------------------------------------------------------------- Status setting
1247:
1248: sub status {
1249: my $what=shift;
1250: my $now=time;
1251: my $local=localtime($now);
1252: $status=$local.': '.$what;
1253: $0='lond: '.$what.' '.$local;
1254: }
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:
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 {
1285: &logthis(
1286: "<font color='red'>CRITICAL: "
1287: ."lonc at pid $loncpid not responding, giving up</font>");
1288: }
1289: } else {
1290: &logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
1291: }
1292: }
1293:
1294: # -------------------------------------------------- Non-critical communication
1295:
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;
1313: if ($server ne $currenthostid) {
1314: $answer=subreply($cmd,$server);
1315: if ($answer eq 'con_lost') {
1316: $answer=subreply("ping",$server);
1317: if ($answer ne $server) {
1318: &logthis("sub reply: answer != server answer is $answer, server is $server");
1319: &reconlonc("$perlvar{'lonSockDir'}/$server");
1320: }
1321: $answer=subreply($cmd,$server);
1322: }
1323: } else {
1324: $answer='self_reply';
1325: }
1326: return $answer;
1327: }
1328:
1329: # -------------------------------------------------------------- Talk to lonsql
1330:
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:
1353: # -------------------------------------------- Return path to profile directory
1354:
1355: sub propath {
1356: my ($udom,$uname)=@_;
1357: $udom=~s/\W//g;
1358: $uname=~s/\W//g;
1359: my $subdir=$uname.'__';
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?
1366:
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:
1382: my $fpid=fork;
1383: exit if $fpid;
1384: die "Couldn't fork: $!" unless defined ($fpid);
1385:
1386: POSIX::setsid() or die "Can't start new session: $!";
1387:
1388: # ------------------------------------------------------- Write our PID on disk
1389:
1390: my $execdir=$perlvar{'lonDaemons'};
1391: open (PIDSAVE,">$execdir/logs/lond.pid");
1392: print PIDSAVE "$$\n";
1393: close(PIDSAVE);
1394: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
1395: &status('Starting');
1396:
1397:
1398:
1399: # ----------------------------------------------------- Install signal handlers
1400:
1401:
1402: $SIG{CHLD} = \&REAPER;
1403: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
1404: $SIG{HUP} = \&HUPSMAN;
1405: $SIG{USR1} = \&checkchildren;
1406: $SIG{USR2} = \&UpdateHosts;
1407:
1408: # Read the host hashes:
1409:
1410: ReadHostTable;
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:
1417: while (1) {
1418: &status('Starting accept');
1419: $client = $server->accept() or next;
1420: &status('Accepted '.$client.' off to spawn');
1421: make_new_child($client);
1422: &status('Finished spawning');
1423: }
1424:
1425: sub make_new_child {
1426: my $pid;
1427: my $cipher;
1428: my $sigset;
1429:
1430: $client = shift;
1431: &status('Starting new child '.$client);
1432: &logthis('<font color="green"> Attempting to start child ('.$client.
1433: ")</font>");
1434: # block signal for fork
1435: $sigset = POSIX::SigSet->new(SIGINT);
1436: sigprocmask(SIG_BLOCK, $sigset)
1437: or die "Can't block SIGINT for fork: $!\n";
1438:
1439: die "fork: $!" unless defined ($pid = fork);
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);
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)) {
1456: $clientip = inet_ntoa($iaddr);
1457: Debug("Connected with $clientip");
1458: $clientdns = gethostbyaddr($iaddr, AF_INET);
1459: Debug("Connected with $clientdns by name");
1460: } else {
1461: &logthis("Unable to determine clientip");
1462: $clientip='Unavailable';
1463: }
1464:
1465: if ($pid) {
1466: # Parent records the child's birth and returns.
1467: sigprocmask(SIG_UNBLOCK, $sigset)
1468: or die "Can't unblock SIGINT for fork: $!\n";
1469: $children{$pid} = $clientip;
1470: &status('Started child '.$pid);
1471: return;
1472: } else {
1473: # Child can *not* return from this subroutine.
1474: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
1475: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
1476: #don't get intercepted
1477: $SIG{USR1}= \&logstatus;
1478: $SIG{ALRM}= \&timeout;
1479: $lastlog='Forked ';
1480: $status='Forked';
1481:
1482: # unblock signals
1483: sigprocmask(SIG_UNBLOCK, $sigset)
1484: or die "Can't unblock SIGINT for fork: $!\n";
1485:
1486: my $tmpsnum=0;
1487: #---------------------------------------------------- kerberos 5 initialization
1488: &Authen::Krb5::init_context();
1489: &Authen::Krb5::init_ets();
1490:
1491: &status('Accepted connection');
1492: # =============================================================================
1493: # do something with the connection
1494: # -----------------------------------------------------------------------------
1495: # see if we know client and 'check' for spoof IP by ineffective challenge
1496:
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;
1513:
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>;
1521: chomp($remotereq);
1522: Debug("Got init: $remotereq");
1523: my $inikeyword = split(/:/, $remotereq);
1524: if ($remotereq =~ /^init/) {
1525: &sethost("sethost:$perlvar{'lonHostID'}");
1526: #
1527: # If the remote is attempting a local init... give that a try:
1528: #
1529: my ($i, $inittype) = split(/:/, $remotereq);
1530: if($inittype eq "local") {
1531: my $key = LocalConnection($client, $remotereq);
1532: if($key) {
1533: Debug("Got local key $key");
1534: $clientok = 1;
1535: my $cipherkey = pack("H32", $key);
1536: $cipher = new IDEA($cipherkey);
1537: print $client "ok:local\n";
1538: &logthis('<font color="green"'
1539: . "Successful local authentication </font>");
1540: } else {
1541: Debug("Failed to get local key");
1542: $clientok = 0;
1543: shutdown($client, 3);
1544: close $client;
1545: }
1546: } elsif ($inittype eq "ssl") {
1547: my $key = SSLConnection($client);
1548: if ($key) {
1549: $clientok = 1;
1550: my $cipherkey = pack("H32", $key);
1551: $cipher = new IDEA($cipherkey);
1552: &logthis('<font color="green">'
1553: ."Successfull ssl authentication </font>");
1554:
1555: } else {
1556: $clientok = 0;
1557: close $client;
1558: }
1559:
1560: } else {
1561: my $ok = InsecureConnection($client);
1562: if($ok) {
1563: $clientok = 1;
1564: &logthis('<font color="green">'
1565: ."Successful insecure authentication </font>");
1566: print $client "ok\n";
1567: } else {
1568: &logthis('<font color="yellow">'
1569: ."Attempted insecure connection disallowed </font>");
1570: close $client;
1571: $clientok = 0;
1572:
1573: }
1574: }
1575: } else {
1576: &logthis(
1577: "<font color='blue'>WARNING: "
1578: ."$clientip failed to initialize: >$remotereq< </font>");
1579: &status('No init '.$clientip);
1580: }
1581:
1582: } else {
1583: &logthis(
1584: "<font color='blue'>WARNING: Unknown client $clientip</font>");
1585: &status('Hung up on '.$clientip);
1586: }
1587:
1588: if ($clientok) {
1589: # ---------------- New known client connecting, could mean machine online again
1590:
1591: foreach my $id (keys(%hostip)) {
1592: if ($hostip{$id} ne $clientip ||
1593: $hostip{$currenthostid} eq $clientip) {
1594: # no need to try to do recon's to myself
1595: next;
1596: }
1597: &reconlonc("$perlvar{'lonSockDir'}/$id");
1598: }
1599: &logthis("<font color='green'>Established connection: $clientname</font>");
1600: &status('Will listen to '.$clientname);
1601: # ------------------------------------------------------------ Process requests
1602: while (my $userinput=<$client>) {
1603: chomp($userinput);
1604: Debug("Request = $userinput\n");
1605: &status('Processing '.$clientname.': '.$userinput);
1606: my $wasenc=0;
1607: alarm(120);
1608: # ------------------------------------------------------------ See if encrypted
1609: if ($userinput =~ /^enc/) {
1610: if ($cipher) {
1611: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
1612: $userinput='';
1613: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
1614: $userinput.=
1615: $cipher->decrypt(
1616: pack("H16",substr($encinput,$encidx,16))
1617: );
1618: }
1619: $userinput=substr($userinput,0,$cmdlength);
1620: $wasenc=1;
1621: }
1622: }
1623:
1624: # ------------------------------------------------------------- Normal commands
1625: # ------------------------------------------------------------------------ ping
1626: if ($userinput =~ /^ping/) { # client only
1627: if(isClient) {
1628: print $client "$currenthostid\n";
1629: } else {
1630: Reply($client, "refused\n", $userinput);
1631: }
1632: # ------------------------------------------------------------------------ pong
1633: }elsif ($userinput =~ /^pong/) { # client only
1634: if(isClient) {
1635: my $reply=&reply("ping",$clientname);
1636: print $client "$currenthostid:$reply\n";
1637: } else {
1638: Reply($client, "refused\n", $userinput);
1639: }
1640: # ------------------------------------------------------------------------ ekey
1641: } elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs
1642: my $buildkey=time.$$.int(rand 100000);
1643: $buildkey=~tr/1-6/A-F/;
1644: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
1645: my $key=$currenthostid.$clientname;
1646: $key=~tr/a-z/A-Z/;
1647: $key=~tr/G-P/0-9/;
1648: $key=~tr/Q-Z/0-9/;
1649: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
1650: $key=substr($key,0,32);
1651: my $cipherkey=pack("H32",$key);
1652: $cipher=new IDEA $cipherkey;
1653: print $client "$buildkey\n";
1654: # ------------------------------------------------------------------------ load
1655: } elsif ($userinput =~ /^load/) { # client only
1656: if (isClient) {
1657: my $loadavg;
1658: {
1659: my $loadfile=IO::File->new('/proc/loadavg');
1660: $loadavg=<$loadfile>;
1661: }
1662: $loadavg =~ s/\s.*//g;
1663: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
1664: print $client "$loadpercent\n";
1665: } else {
1666: Reply($client, "refused\n", $userinput);
1667:
1668: }
1669: # -------------------------------------------------------------------- userload
1670: } elsif ($userinput =~ /^userload/) { # client only
1671: if(isClient) {
1672: my $userloadpercent=&userload();
1673: print $client "$userloadpercent\n";
1674: } else {
1675: Reply($client, "refused\n", $userinput);
1676:
1677: }
1678: #
1679: # Transactions requiring encryption:
1680: #
1681: # ----------------------------------------------------------------- currentauth
1682: } elsif ($userinput =~ /^currentauth/) {
1683: if (($wasenc==1) && isClient) { # Encoded & client only.
1684: my ($cmd,$udom,$uname)=split(/:/,$userinput);
1685: my $result = GetAuthType($udom, $uname);
1686: if($result eq "nouser") {
1687: print $client "unknown_user\n";
1688: }
1689: else {
1690: print $client "$result\n"
1691: }
1692: } else {
1693: Reply($client, "refused\n", $userinput);
1694:
1695: }
1696: #--------------------------------------------------------------------- pushfile
1697: } elsif($userinput =~ /^pushfile/) { # encoded & manager.
1698: if(($wasenc == 1) && isManager) {
1699: my $cert = GetCertificate($userinput);
1700: if(ValidManager($cert)) {
1701: my $reply = PushFile($userinput);
1702: print $client "$reply\n";
1703: } else {
1704: print $client "refused\n";
1705: }
1706: } else {
1707: Reply($client, "refused\n", $userinput);
1708:
1709: }
1710: #--------------------------------------------------------------------- reinit
1711: } elsif($userinput =~ /^reinit/) { # Encoded and manager
1712: if (($wasenc == 1) && isManager) {
1713: my $cert = GetCertificate($userinput);
1714: if(ValidManager($cert)) {
1715: chomp($userinput);
1716: my $reply = ReinitProcess($userinput);
1717: print $client "$reply\n";
1718: } else {
1719: print $client "refused\n";
1720: }
1721: } else {
1722: Reply($client, "refused\n", $userinput);
1723: }
1724: #------------------------------------------------------------------------- edit
1725: } elsif ($userinput =~ /^edit/) { # encoded and manager:
1726: if(($wasenc ==1) && (isManager)) {
1727: my $cert = GetCertificate($userinput);
1728: if(ValidManager($cert)) {
1729: my($command, $filetype, $script) = split(/:/, $userinput);
1730: if (($filetype eq "hosts") || ($filetype eq "domain")) {
1731: if($script ne "") {
1732: Reply($client, EditFile($userinput));
1733: } else {
1734: Reply($client,"refused\n",$userinput);
1735: }
1736: } else {
1737: Reply($client,"refused\n",$userinput);
1738: }
1739: } else {
1740: Reply($client,"refused\n",$userinput);
1741: }
1742: } else {
1743: Reply($client,"refused\n",$userinput);
1744: }
1745: # ------------------------------------------------------------------------ auth
1746: } elsif ($userinput =~ /^auth/) { # Encoded and client only.
1747: if (($wasenc==1) && isClient) {
1748: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
1749: chomp($upass);
1750: $upass=unescape($upass);
1751: my $proname=propath($udom,$uname);
1752: my $passfilename="$proname/passwd";
1753: if (-e $passfilename) {
1754: my $pf = IO::File->new($passfilename);
1755: my $realpasswd=<$pf>;
1756: chomp($realpasswd);
1757: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
1758: my $pwdcorrect=0;
1759: if ($howpwd eq 'internal') {
1760: &Debug("Internal auth");
1761: $pwdcorrect=
1762: (crypt($upass,$contentpwd) eq $contentpwd);
1763: } elsif ($howpwd eq 'unix') {
1764: &Debug("Unix auth");
1765: if((getpwnam($uname))[1] eq "") { #no such user!
1766: $pwdcorrect = 0;
1767: } else {
1768: $contentpwd=(getpwnam($uname))[1];
1769: my $pwauth_path="/usr/local/sbin/pwauth";
1770: unless ($contentpwd eq 'x') {
1771: $pwdcorrect=
1772: (crypt($upass,$contentpwd) eq
1773: $contentpwd);
1774: }
1775:
1776: elsif (-e $pwauth_path) {
1777: open PWAUTH, "|$pwauth_path" or
1778: die "Cannot invoke authentication";
1779: print PWAUTH "$uname\n$upass\n";
1780: close PWAUTH;
1781: $pwdcorrect=!$?;
1782: }
1783: }
1784: } elsif ($howpwd eq 'krb4') {
1785: my $null=pack("C",0);
1786: unless ($upass=~/$null/) {
1787: my $krb4_error = &Authen::Krb4::get_pw_in_tkt
1788: ($uname,"",$contentpwd,'krbtgt',
1789: $contentpwd,1,$upass);
1790: if (!$krb4_error) {
1791: $pwdcorrect = 1;
1792: } else {
1793: $pwdcorrect=0;
1794: # log error if it is not a bad password
1795: if ($krb4_error != 62) {
1796: &logthis('krb4:'.$uname.','.
1797: &Authen::Krb4::get_err_txt($Authen::Krb4::error));
1798: }
1799: }
1800: }
1801: } elsif ($howpwd eq 'krb5') {
1802: my $null=pack("C",0);
1803: unless ($upass=~/$null/) {
1804: my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
1805: my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
1806: my $krbserver=&Authen::Krb5::parse_name($krbservice);
1807: my $credentials=&Authen::Krb5::cc_default();
1808: $credentials->initialize($krbclient);
1809: my $krbreturn =
1810: &Authen::Krb5::get_in_tkt_with_password(
1811: $krbclient,$krbserver,$upass,$credentials);
1812: # unless ($krbreturn) {
1813: # &logthis("Krb5 Error: ".
1814: # &Authen::Krb5::error());
1815: # }
1816: $pwdcorrect = ($krbreturn == 1);
1817: } else { $pwdcorrect=0; }
1818: } elsif ($howpwd eq 'localauth') {
1819: $pwdcorrect=&localauth::localauth($uname,$upass,
1820: $contentpwd);
1821: }
1822: if ($pwdcorrect) {
1823: print $client "authorized\n";
1824: } else {
1825: print $client "non_authorized\n";
1826: }
1827: } else {
1828: print $client "unknown_user\n";
1829: }
1830: } else {
1831: Reply($client, "refused\n", $userinput);
1832:
1833: }
1834: # ---------------------------------------------------------------------- passwd
1835: } elsif ($userinput =~ /^passwd/) { # encoded and client
1836: if (($wasenc==1) && isClient) {
1837: my
1838: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
1839: chomp($npass);
1840: $upass=&unescape($upass);
1841: $npass=&unescape($npass);
1842: &Debug("Trying to change password for $uname");
1843: my $proname=propath($udom,$uname);
1844: my $passfilename="$proname/passwd";
1845: if (-e $passfilename) {
1846: my $realpasswd;
1847: { my $pf = IO::File->new($passfilename);
1848: $realpasswd=<$pf>; }
1849: chomp($realpasswd);
1850: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
1851: if ($howpwd eq 'internal') {
1852: &Debug("internal auth");
1853: if (crypt($upass,$contentpwd) eq $contentpwd) {
1854: my $salt=time;
1855: $salt=substr($salt,6,2);
1856: my $ncpass=crypt($npass,$salt);
1857: {
1858: my $pf;
1859: if ($pf = IO::File->new(">$passfilename")) {
1860: print $pf "internal:$ncpass\n";
1861: &logthis("Result of password change for $uname: pwchange_success");
1862: print $client "ok\n";
1863: } else {
1864: &logthis("Unable to open $uname passwd to change password");
1865: print $client "non_authorized\n";
1866: }
1867: }
1868:
1869: } else {
1870: print $client "non_authorized\n";
1871: }
1872: } elsif ($howpwd eq 'unix') {
1873: # Unix means we have to access /etc/password
1874: # one way or another.
1875: # First: Make sure the current password is
1876: # correct
1877: &Debug("auth is unix");
1878: $contentpwd=(getpwnam($uname))[1];
1879: my $pwdcorrect = "0";
1880: my $pwauth_path="/usr/local/sbin/pwauth";
1881: unless ($contentpwd eq 'x') {
1882: $pwdcorrect=
1883: (crypt($upass,$contentpwd) eq $contentpwd);
1884: } elsif (-e $pwauth_path) {
1885: open PWAUTH, "|$pwauth_path" or
1886: die "Cannot invoke authentication";
1887: print PWAUTH "$uname\n$upass\n";
1888: close PWAUTH;
1889: &Debug("exited pwauth with $? ($uname,$upass) ");
1890: $pwdcorrect=($? == 0);
1891: }
1892: if ($pwdcorrect) {
1893: my $execdir=$perlvar{'lonDaemons'};
1894: &Debug("Opening lcpasswd pipeline");
1895: my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
1896: print $pf "$uname\n$npass\n$npass\n";
1897: close $pf;
1898: my $err = $?;
1899: my $result = ($err>0 ? 'pwchange_failure'
1900: : 'ok');
1901: &logthis("Result of password change for $uname: ".
1902: &lcpasswdstrerror($?));
1903: print $client "$result\n";
1904: } else {
1905: print $client "non_authorized\n";
1906: }
1907: } else {
1908: print $client "auth_mode_error\n";
1909: }
1910: } else {
1911: print $client "unknown_user\n";
1912: }
1913: } else {
1914: Reply($client, "refused\n", $userinput);
1915:
1916: }
1917: # -------------------------------------------------------------------- makeuser
1918: } elsif ($userinput =~ /^makeuser/) { # encoded and client.
1919: &Debug("Make user received");
1920: my $oldumask=umask(0077);
1921: if (($wasenc==1) && isClient) {
1922: my
1923: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
1924: &Debug("cmd =".$cmd." $udom =".$udom.
1925: " uname=".$uname);
1926: chomp($npass);
1927: $npass=&unescape($npass);
1928: my $proname=propath($udom,$uname);
1929: my $passfilename="$proname/passwd";
1930: &Debug("Password file created will be:".
1931: $passfilename);
1932: if (-e $passfilename) {
1933: print $client "already_exists\n";
1934: } elsif ($udom ne $currentdomainid) {
1935: print $client "not_right_domain\n";
1936: } else {
1937: my @fpparts=split(/\//,$proname);
1938: my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
1939: my $fperror='';
1940: for (my $i=3;$i<=$#fpparts;$i++) {
1941: $fpnow.='/'.$fpparts[$i];
1942: unless (-e $fpnow) {
1943: unless (mkdir($fpnow,0777)) {
1944: $fperror="error: ".($!+0)
1945: ." mkdir failed while attempting "
1946: ."makeuser";
1947: }
1948: }
1949: }
1950: unless ($fperror) {
1951: my $result=&make_passwd_file($uname, $umode,$npass,
1952: $passfilename);
1953: print $client $result;
1954: } else {
1955: print $client "$fperror\n";
1956: }
1957: }
1958: } else {
1959: Reply($client, "refused\n", $userinput);
1960:
1961: }
1962: umask($oldumask);
1963: # -------------------------------------------------------------- changeuserauth
1964: } elsif ($userinput =~ /^changeuserauth/) { # encoded & client
1965: &Debug("Changing authorization");
1966: if (($wasenc==1) && isClient) {
1967: my
1968: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
1969: chomp($npass);
1970: &Debug("cmd = ".$cmd." domain= ".$udom.
1971: "uname =".$uname." umode= ".$umode);
1972: $npass=&unescape($npass);
1973: my $proname=&propath($udom,$uname);
1974: my $passfilename="$proname/passwd";
1975: if ($udom ne $currentdomainid) {
1976: print $client "not_right_domain\n";
1977: } else {
1978: my $result=&make_passwd_file($uname, $umode,$npass,
1979: $passfilename);
1980: print $client $result;
1981: }
1982: } else {
1983: Reply($client, "refused\n", $userinput);
1984:
1985: }
1986: # ------------------------------------------------------------------------ home
1987: } elsif ($userinput =~ /^home/) { # client clear or encoded
1988: if(isClient) {
1989: my ($cmd,$udom,$uname)=split(/:/,$userinput);
1990: chomp($uname);
1991: my $proname=propath($udom,$uname);
1992: if (-e $proname) {
1993: print $client "found\n";
1994: } else {
1995: print $client "not_found\n";
1996: }
1997: } else {
1998: Reply($client, "refused\n", $userinput);
1999:
2000: }
2001: # ---------------------------------------------------------------------- update
2002: } elsif ($userinput =~ /^update/) { # client clear or encoded.
2003: if(isClient) {
2004: my ($cmd,$fname)=split(/:/,$userinput);
2005: my $ownership=ishome($fname);
2006: if ($ownership eq 'not_owner') {
2007: if (-e $fname) {
2008: my ($dev,$ino,$mode,$nlink,
2009: $uid,$gid,$rdev,$size,
2010: $atime,$mtime,$ctime,
2011: $blksize,$blocks)=stat($fname);
2012: my $now=time;
2013: my $since=$now-$atime;
2014: if ($since>$perlvar{'lonExpire'}) {
2015: my $reply=
2016: &reply("unsub:$fname","$clientname");
2017: unlink("$fname");
2018: } else {
2019: my $transname="$fname.in.transfer";
2020: my $remoteurl=
2021: &reply("sub:$fname","$clientname");
2022: my $response;
2023: {
2024: my $ua=new LWP::UserAgent;
2025: my $request=new HTTP::Request('GET',"$remoteurl");
2026: $response=$ua->request($request,$transname);
2027: }
2028: if ($response->is_error()) {
2029: unlink($transname);
2030: my $message=$response->status_line;
2031: &logthis(
2032: "LWP GET: $message for $fname ($remoteurl)");
2033: } else {
2034: if ($remoteurl!~/\.meta$/) {
2035: my $ua=new LWP::UserAgent;
2036: my $mrequest=
2037: new HTTP::Request('GET',$remoteurl.'.meta');
2038: my $mresponse=
2039: $ua->request($mrequest,$fname.'.meta');
2040: if ($mresponse->is_error()) {
2041: unlink($fname.'.meta');
2042: }
2043: }
2044: rename($transname,$fname);
2045: }
2046: }
2047: print $client "ok\n";
2048: } else {
2049: print $client "not_found\n";
2050: }
2051: } else {
2052: print $client "rejected\n";
2053: }
2054: } else {
2055: Reply($client, "refused\n", $userinput);
2056:
2057: }
2058: # -------------------------------------- fetch a user file from a remote server
2059: } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
2060: if(isClient) {
2061: my ($cmd,$fname)=split(/:/,$userinput);
2062: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
2063: my $udir=propath($udom,$uname).'/userfiles';
2064: unless (-e $udir) { mkdir($udir,0770); }
2065: if (-e $udir) {
2066: $ufile=~s/^[\.\~]+//;
2067: my $path = $udir;
2068: if ($ufile =~m|(.+)/([^/]+)$|) {
2069: my @parts=split('/',$1);
2070: foreach my $part (@parts) {
2071: $path .= '/'.$part;
2072: if ((-e $path)!=1) {
2073: mkdir($path,0770);
2074: }
2075: }
2076: }
2077: my $destname=$udir.'/'.$ufile;
2078: my $transname=$udir.'/'.$ufile.'.in.transit';
2079: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
2080: my $response;
2081: {
2082: my $ua=new LWP::UserAgent;
2083: my $request=new HTTP::Request('GET',"$remoteurl");
2084: $response=$ua->request($request,$transname);
2085: }
2086: if ($response->is_error()) {
2087: unlink($transname);
2088: my $message=$response->status_line;
2089: &logthis("LWP GET: $message for $fname ($remoteurl)");
2090: print $client "failed\n";
2091: } else {
2092: if (!rename($transname,$destname)) {
2093: &logthis("Unable to move $transname to $destname");
2094: unlink($transname);
2095: print $client "failed\n";
2096: } else {
2097: print $client "ok\n";
2098: }
2099: }
2100: } else {
2101: print $client "not_home\n";
2102: }
2103: } else {
2104: Reply($client, "refused\n", $userinput);
2105: }
2106: # --------------------------------------------------------- remove a user file
2107: } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
2108: if(isClient) {
2109: my ($cmd,$fname)=split(/:/,$userinput);
2110: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
2111: &logthis("$udom - $uname - $ufile");
2112: if ($ufile =~m|/\.\./|) {
2113: # any files paths with /../ in them refuse
2114: # to deal with
2115: print $client "refused\n";
2116: } else {
2117: my $udir=propath($udom,$uname);
2118: if (-e $udir) {
2119: my $file=$udir.'/userfiles/'.$ufile;
2120: if (-e $file) {
2121: unlink($file);
2122: if (-e $file) {
2123: print $client "failed\n";
2124: } else {
2125: print $client "ok\n";
2126: }
2127: } else {
2128: print $client "not_found\n";
2129: }
2130: } else {
2131: print $client "not_home\n";
2132: }
2133: }
2134: } else {
2135: Reply($client, "refused\n", $userinput);
2136: }
2137: # ------------------------------------------ authenticate access to a user file
2138: } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
2139: if(isClient) {
2140: my ($cmd,$fname,$session)=split(/:/,$userinput);
2141: chomp($session);
2142: my $reply='non_auth';
2143: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
2144: $session.'.id')) {
2145: while (my $line=<ENVIN>) {
2146: if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
2147: }
2148: close(ENVIN);
2149: print $client $reply."\n";
2150: } else {
2151: print $client "invalid_token\n";
2152: }
2153: } else {
2154: Reply($client, "refused\n", $userinput);
2155:
2156: }
2157: # ----------------------------------------------------------------- unsubscribe
2158: } elsif ($userinput =~ /^unsub/) {
2159: if(isClient) {
2160: my ($cmd,$fname)=split(/:/,$userinput);
2161: if (-e $fname) {
2162: print $client &unsub($fname,$clientip);
2163: } else {
2164: print $client "not_found\n";
2165: }
2166: } else {
2167: Reply($client, "refused\n", $userinput);
2168:
2169: }
2170: # ------------------------------------------------------------------- subscribe
2171: } elsif ($userinput =~ /^sub/) {
2172: if(isClient) {
2173: print $client &subscribe($userinput,$clientip);
2174: } else {
2175: Reply($client, "refused\n", $userinput);
2176:
2177: }
2178: # ------------------------------------------------------------- current version
2179: } elsif ($userinput =~ /^currentversion/) {
2180: if(isClient) {
2181: my ($cmd,$fname)=split(/:/,$userinput);
2182: print $client ¤tversion($fname)."\n";
2183: } else {
2184: Reply($client, "refused\n", $userinput);
2185:
2186: }
2187: # ------------------------------------------------------------------------- log
2188: } elsif ($userinput =~ /^log/) {
2189: if(isClient) {
2190: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
2191: chomp($what);
2192: my $proname=propath($udom,$uname);
2193: my $now=time;
2194: {
2195: my $hfh;
2196: if ($hfh=IO::File->new(">>$proname/activity.log")) {
2197: print $hfh "$now:$clientname:$what\n";
2198: print $client "ok\n";
2199: } else {
2200: print $client "error: ".($!+0)
2201: ." IO::File->new Failed "
2202: ."while attempting log\n";
2203: }
2204: }
2205: } else {
2206: Reply($client, "refused\n", $userinput);
2207:
2208: }
2209: # ------------------------------------------------------------------------- put
2210: } elsif ($userinput =~ /^put/) {
2211: if(isClient) {
2212: my ($cmd,$udom,$uname,$namespace,$what)
2213: =split(/:/,$userinput);
2214: $namespace=~s/\//\_/g;
2215: $namespace=~s/\W//g;
2216: if ($namespace ne 'roles') {
2217: chomp($what);
2218: my $proname=propath($udom,$uname);
2219: my $now=time;
2220: unless ($namespace=~/^nohist\_/) {
2221: my $hfh;
2222: if (
2223: $hfh=IO::File->new(">>$proname/$namespace.hist")
2224: ) { print $hfh "P:$now:$what\n"; }
2225: }
2226: my @pairs=split(/\&/,$what);
2227: my %hash;
2228: if (tie(%hash,'GDBM_File',
2229: "$proname/$namespace.db",
2230: &GDBM_WRCREAT(),0640)) {
2231: foreach my $pair (@pairs) {
2232: my ($key,$value)=split(/=/,$pair);
2233: $hash{$key}=$value;
2234: }
2235: if (untie(%hash)) {
2236: print $client "ok\n";
2237: } else {
2238: print $client "error: ".($!+0)
2239: ." untie(GDBM) failed ".
2240: "while attempting put\n";
2241: }
2242: } else {
2243: print $client "error: ".($!)
2244: ." tie(GDBM) Failed ".
2245: "while attempting put\n";
2246: }
2247: } else {
2248: print $client "refused\n";
2249: }
2250: } else {
2251: Reply($client, "refused\n", $userinput);
2252:
2253: }
2254: # ------------------------------------------------------------------- inc
2255: } elsif ($userinput =~ /^inc:/) {
2256: if(isClient) {
2257: my ($cmd,$udom,$uname,$namespace,$what)
2258: =split(/:/,$userinput);
2259: $namespace=~s/\//\_/g;
2260: $namespace=~s/\W//g;
2261: if ($namespace ne 'roles') {
2262: chomp($what);
2263: my $proname=propath($udom,$uname);
2264: my $now=time;
2265: unless ($namespace=~/^nohist\_/) {
2266: my $hfh;
2267: if (
2268: $hfh=IO::File->new(">>$proname/$namespace.hist")
2269: ) { print $hfh "P:$now:$what\n"; }
2270: }
2271: my @pairs=split(/\&/,$what);
2272: my %hash;
2273: if (tie(%hash,'GDBM_File',
2274: "$proname/$namespace.db",
2275: &GDBM_WRCREAT(),0640)) {
2276: foreach my $pair (@pairs) {
2277: my ($key,$value)=split(/=/,$pair);
2278: # We could check that we have a number...
2279: if (! defined($value) || $value eq '') {
2280: $value = 1;
2281: }
2282: $hash{$key}+=$value;
2283: }
2284: if (untie(%hash)) {
2285: print $client "ok\n";
2286: } else {
2287: print $client "error: ".($!+0)
2288: ." untie(GDBM) failed ".
2289: "while attempting inc\n";
2290: }
2291: } else {
2292: print $client "error: ".($!)
2293: ." tie(GDBM) Failed ".
2294: "while attempting inc\n";
2295: }
2296: } else {
2297: print $client "refused\n";
2298: }
2299: } else {
2300: Reply($client, "refused\n", $userinput);
2301:
2302: }
2303: # -------------------------------------------------------------------- rolesput
2304: } elsif ($userinput =~ /^rolesput/) {
2305: if(isClient) {
2306: &Debug("rolesput");
2307: if ($wasenc==1) {
2308: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
2309: =split(/:/,$userinput);
2310: &Debug("cmd = ".$cmd." exedom= ".$exedom.
2311: "user = ".$exeuser." udom=".$udom.
2312: "what = ".$what);
2313: my $namespace='roles';
2314: chomp($what);
2315: my $proname=propath($udom,$uname);
2316: my $now=time;
2317: {
2318: my $hfh;
2319: if (
2320: $hfh=IO::File->new(">>$proname/$namespace.hist")
2321: ) {
2322: print $hfh "P:$now:$exedom:$exeuser:$what\n";
2323: }
2324: }
2325: my @pairs=split(/\&/,$what);
2326: my %hash;
2327: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
2328: foreach my $pair (@pairs) {
2329: my ($key,$value)=split(/=/,$pair);
2330: &ManagePermissions($key, $udom, $uname,
2331: &GetAuthType( $udom,
2332: $uname));
2333: $hash{$key}=$value;
2334: }
2335: if (untie(%hash)) {
2336: print $client "ok\n";
2337: } else {
2338: print $client "error: ".($!+0)
2339: ." untie(GDBM) Failed ".
2340: "while attempting rolesput\n";
2341: }
2342: } else {
2343: print $client "error: ".($!+0)
2344: ." tie(GDBM) Failed ".
2345: "while attempting rolesput\n";
2346: }
2347: } else {
2348: print $client "refused\n";
2349: }
2350: } else {
2351: Reply($client, "refused\n", $userinput);
2352:
2353: }
2354: # -------------------------------------------------------------------- rolesdel
2355: } elsif ($userinput =~ /^rolesdel/) {
2356: if(isClient) {
2357: &Debug("rolesdel");
2358: if ($wasenc==1) {
2359: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
2360: =split(/:/,$userinput);
2361: &Debug("cmd = ".$cmd." exedom= ".$exedom.
2362: "user = ".$exeuser." udom=".$udom.
2363: "what = ".$what);
2364: my $namespace='roles';
2365: chomp($what);
2366: my $proname=propath($udom,$uname);
2367: my $now=time;
2368: {
2369: my $hfh;
2370: if (
2371: $hfh=IO::File->new(">>$proname/$namespace.hist")
2372: ) {
2373: print $hfh "D:$now:$exedom:$exeuser:$what\n";
2374: }
2375: }
2376: my @rolekeys=split(/\&/,$what);
2377: my %hash;
2378: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
2379: foreach my $key (@rolekeys) {
2380: delete $hash{$key};
2381: }
2382: if (untie(%hash)) {
2383: print $client "ok\n";
2384: } else {
2385: print $client "error: ".($!+0)
2386: ." untie(GDBM) Failed ".
2387: "while attempting rolesdel\n";
2388: }
2389: } else {
2390: print $client "error: ".($!+0)
2391: ." tie(GDBM) Failed ".
2392: "while attempting rolesdel\n";
2393: }
2394: } else {
2395: print $client "refused\n";
2396: }
2397: } else {
2398: Reply($client, "refused\n", $userinput);
2399:
2400: }
2401: # ------------------------------------------------------------------------- get
2402: } elsif ($userinput =~ /^get/) {
2403: if(isClient) {
2404: my ($cmd,$udom,$uname,$namespace,$what)
2405: =split(/:/,$userinput);
2406: $namespace=~s/\//\_/g;
2407: $namespace=~s/\W//g;
2408: chomp($what);
2409: my @queries=split(/\&/,$what);
2410: my $proname=propath($udom,$uname);
2411: my $qresult='';
2412: my %hash;
2413: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2414: for (my $i=0;$i<=$#queries;$i++) {
2415: $qresult.="$hash{$queries[$i]}&";
2416: }
2417: if (untie(%hash)) {
2418: $qresult=~s/\&$//;
2419: print $client "$qresult\n";
2420: } else {
2421: print $client "error: ".($!+0)
2422: ." untie(GDBM) Failed ".
2423: "while attempting get\n";
2424: }
2425: } else {
2426: if ($!+0 == 2) {
2427: print $client "error:No such file or ".
2428: "GDBM reported bad block error\n";
2429: } else {
2430: print $client "error: ".($!+0)
2431: ." tie(GDBM) Failed ".
2432: "while attempting get\n";
2433: }
2434: }
2435: } else {
2436: Reply($client, "refused\n", $userinput);
2437:
2438: }
2439: # ------------------------------------------------------------------------ eget
2440: } elsif ($userinput =~ /^eget/) {
2441: if (isClient) {
2442: my ($cmd,$udom,$uname,$namespace,$what)
2443: =split(/:/,$userinput);
2444: $namespace=~s/\//\_/g;
2445: $namespace=~s/\W//g;
2446: chomp($what);
2447: my @queries=split(/\&/,$what);
2448: my $proname=propath($udom,$uname);
2449: my $qresult='';
2450: my %hash;
2451: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2452: for (my $i=0;$i<=$#queries;$i++) {
2453: $qresult.="$hash{$queries[$i]}&";
2454: }
2455: if (untie(%hash)) {
2456: $qresult=~s/\&$//;
2457: if ($cipher) {
2458: my $cmdlength=length($qresult);
2459: $qresult.=" ";
2460: my $encqresult='';
2461: for
2462: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
2463: $encqresult.=
2464: unpack("H16",
2465: $cipher->encrypt(substr($qresult,$encidx,8)));
2466: }
2467: print $client "enc:$cmdlength:$encqresult\n";
2468: } else {
2469: print $client "error:no_key\n";
2470: }
2471: } else {
2472: print $client "error: ".($!+0)
2473: ." untie(GDBM) Failed ".
2474: "while attempting eget\n";
2475: }
2476: } else {
2477: print $client "error: ".($!+0)
2478: ." tie(GDBM) Failed ".
2479: "while attempting eget\n";
2480: }
2481: } else {
2482: Reply($client, "refused\n", $userinput);
2483:
2484: }
2485: # ------------------------------------------------------------------------- del
2486: } elsif ($userinput =~ /^del/) {
2487: if(isClient) {
2488: my ($cmd,$udom,$uname,$namespace,$what)
2489: =split(/:/,$userinput);
2490: $namespace=~s/\//\_/g;
2491: $namespace=~s/\W//g;
2492: chomp($what);
2493: my $proname=propath($udom,$uname);
2494: my $now=time;
2495: unless ($namespace=~/^nohist\_/) {
2496: my $hfh;
2497: if (
2498: $hfh=IO::File->new(">>$proname/$namespace.hist")
2499: ) { print $hfh "D:$now:$what\n"; }
2500: }
2501: my @keys=split(/\&/,$what);
2502: my %hash;
2503: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
2504: foreach my $key (@keys) {
2505: delete($hash{$key});
2506: }
2507: if (untie(%hash)) {
2508: print $client "ok\n";
2509: } else {
2510: print $client "error: ".($!+0)
2511: ." untie(GDBM) Failed ".
2512: "while attempting del\n";
2513: }
2514: } else {
2515: print $client "error: ".($!+0)
2516: ." tie(GDBM) Failed ".
2517: "while attempting del\n";
2518: }
2519: } else {
2520: Reply($client, "refused\n", $userinput);
2521:
2522: }
2523: # ------------------------------------------------------------------------ keys
2524: } elsif ($userinput =~ /^keys/) {
2525: if(isClient) {
2526: my ($cmd,$udom,$uname,$namespace)
2527: =split(/:/,$userinput);
2528: $namespace=~s/\//\_/g;
2529: $namespace=~s/\W//g;
2530: my $proname=propath($udom,$uname);
2531: my $qresult='';
2532: my %hash;
2533: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2534: foreach my $key (keys %hash) {
2535: $qresult.="$key&";
2536: }
2537: if (untie(%hash)) {
2538: $qresult=~s/\&$//;
2539: print $client "$qresult\n";
2540: } else {
2541: print $client "error: ".($!+0)
2542: ." untie(GDBM) Failed ".
2543: "while attempting keys\n";
2544: }
2545: } else {
2546: print $client "error: ".($!+0)
2547: ." tie(GDBM) Failed ".
2548: "while attempting keys\n";
2549: }
2550: } else {
2551: Reply($client, "refused\n", $userinput);
2552:
2553: }
2554: # ----------------------------------------------------------------- dumpcurrent
2555: } elsif ($userinput =~ /^currentdump/) {
2556: if (isClient) {
2557: my ($cmd,$udom,$uname,$namespace)
2558: =split(/:/,$userinput);
2559: $namespace=~s/\//\_/g;
2560: $namespace=~s/\W//g;
2561: my $qresult='';
2562: my $proname=propath($udom,$uname);
2563: my %hash;
2564: if (tie(%hash,'GDBM_File',
2565: "$proname/$namespace.db",
2566: &GDBM_READER(),0640)) {
2567: # Structure of %data:
2568: # $data{$symb}->{$parameter}=$value;
2569: # $data{$symb}->{'v.'.$parameter}=$version;
2570: # since $parameter will be unescaped, we do not
2571: # have to worry about silly parameter names...
2572: my %data = ();
2573: while (my ($key,$value) = each(%hash)) {
2574: my ($v,$symb,$param) = split(/:/,$key);
2575: next if ($v eq 'version' || $symb eq 'keys');
2576: next if (exists($data{$symb}) &&
2577: exists($data{$symb}->{$param}) &&
2578: $data{$symb}->{'v.'.$param} > $v);
2579: $data{$symb}->{$param}=$value;
2580: $data{$symb}->{'v.'.$param}=$v;
2581: }
2582: if (untie(%hash)) {
2583: while (my ($symb,$param_hash) = each(%data)) {
2584: while(my ($param,$value) = each (%$param_hash)){
2585: next if ($param =~ /^v\./);
2586: $qresult.=$symb.':'.$param.'='.$value.'&';
2587: }
2588: }
2589: chop($qresult);
2590: print $client "$qresult\n";
2591: } else {
2592: print $client "error: ".($!+0)
2593: ." untie(GDBM) Failed ".
2594: "while attempting currentdump\n";
2595: }
2596: } else {
2597: print $client "error: ".($!+0)
2598: ." tie(GDBM) Failed ".
2599: "while attempting currentdump\n";
2600: }
2601: } else {
2602: Reply($client, "refused\n", $userinput);
2603: }
2604: # ------------------------------------------------------------------------ dump
2605: } elsif ($userinput =~ /^dump/) {
2606: if(isClient) {
2607: my ($cmd,$udom,$uname,$namespace,$regexp)
2608: =split(/:/,$userinput);
2609: $namespace=~s/\//\_/g;
2610: $namespace=~s/\W//g;
2611: if (defined($regexp)) {
2612: $regexp=&unescape($regexp);
2613: } else {
2614: $regexp='.';
2615: }
2616: my $qresult='';
2617: my $proname=propath($udom,$uname);
2618: my %hash;
2619: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2620: while (my ($key,$value) = each(%hash)) {
2621: if ($regexp eq '.') {
2622: $qresult.=$key.'='.$value.'&';
2623: } else {
2624: my $unescapeKey = &unescape($key);
2625: if (eval('$unescapeKey=~/$regexp/')) {
2626: $qresult.="$key=$value&";
2627: }
2628: }
2629: }
2630: if (untie(%hash)) {
2631: chop($qresult);
2632: print $client "$qresult\n";
2633: } else {
2634: print $client "error: ".($!+0)
2635: ." untie(GDBM) Failed ".
2636: "while attempting dump\n";
2637: }
2638: } else {
2639: print $client "error: ".($!+0)
2640: ." tie(GDBM) Failed ".
2641: "while attempting dump\n";
2642: }
2643: } else {
2644: Reply($client, "refused\n", $userinput);
2645:
2646: }
2647: # ----------------------------------------------------------------------- store
2648: } elsif ($userinput =~ /^store/) {
2649: if(isClient) {
2650: my ($cmd,$udom,$uname,$namespace,$rid,$what)
2651: =split(/:/,$userinput);
2652: $namespace=~s/\//\_/g;
2653: $namespace=~s/\W//g;
2654: if ($namespace ne 'roles') {
2655: chomp($what);
2656: my $proname=propath($udom,$uname);
2657: my $now=time;
2658: unless ($namespace=~/^nohist\_/) {
2659: my $hfh;
2660: if (
2661: $hfh=IO::File->new(">>$proname/$namespace.hist")
2662: ) { print $hfh "P:$now:$rid:$what\n"; }
2663: }
2664: my @pairs=split(/\&/,$what);
2665: my %hash;
2666: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
2667: my @previouskeys=split(/&/,$hash{"keys:$rid"});
2668: my $key;
2669: $hash{"version:$rid"}++;
2670: my $version=$hash{"version:$rid"};
2671: my $allkeys='';
2672: foreach my $pair (@pairs) {
2673: my ($key,$value)=split(/=/,$pair);
2674: $allkeys.=$key.':';
2675: $hash{"$version:$rid:$key"}=$value;
2676: }
2677: $hash{"$version:$rid:timestamp"}=$now;
2678: $allkeys.='timestamp';
2679: $hash{"$version:keys:$rid"}=$allkeys;
2680: if (untie(%hash)) {
2681: print $client "ok\n";
2682: } else {
2683: print $client "error: ".($!+0)
2684: ." untie(GDBM) Failed ".
2685: "while attempting store\n";
2686: }
2687: } else {
2688: print $client "error: ".($!+0)
2689: ." tie(GDBM) Failed ".
2690: "while attempting store\n";
2691: }
2692: } else {
2693: print $client "refused\n";
2694: }
2695: } else {
2696: Reply($client, "refused\n", $userinput);
2697:
2698: }
2699: # --------------------------------------------------------------------- restore
2700: } elsif ($userinput =~ /^restore/) {
2701: if(isClient) {
2702: my ($cmd,$udom,$uname,$namespace,$rid)
2703: =split(/:/,$userinput);
2704: $namespace=~s/\//\_/g;
2705: $namespace=~s/\W//g;
2706: chomp($rid);
2707: my $proname=propath($udom,$uname);
2708: my $qresult='';
2709: my %hash;
2710: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2711: my $version=$hash{"version:$rid"};
2712: $qresult.="version=$version&";
2713: my $scope;
2714: for ($scope=1;$scope<=$version;$scope++) {
2715: my $vkeys=$hash{"$scope:keys:$rid"};
2716: my @keys=split(/:/,$vkeys);
2717: my $key;
2718: $qresult.="$scope:keys=$vkeys&";
2719: foreach $key (@keys) {
2720: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
2721: }
2722: }
2723: if (untie(%hash)) {
2724: $qresult=~s/\&$//;
2725: print $client "$qresult\n";
2726: } else {
2727: print $client "error: ".($!+0)
2728: ." untie(GDBM) Failed ".
2729: "while attempting restore\n";
2730: }
2731: } else {
2732: print $client "error: ".($!+0)
2733: ." tie(GDBM) Failed ".
2734: "while attempting restore\n";
2735: }
2736: } else {
2737: Reply($client, "refused\n", $userinput);
2738:
2739: }
2740: # -------------------------------------------------------------------- chatsend
2741: } elsif ($userinput =~ /^chatsend/) {
2742: if(isClient) {
2743: my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
2744: &chatadd($cdom,$cnum,$newpost);
2745: print $client "ok\n";
2746: } else {
2747: Reply($client, "refused\n", $userinput);
2748:
2749: }
2750: # -------------------------------------------------------------------- chatretr
2751: } elsif ($userinput =~ /^chatretr/) {
2752: if(isClient) {
2753: my
2754: ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
2755: my $reply='';
2756: foreach (&getchat($cdom,$cnum,$udom,$uname)) {
2757: $reply.=&escape($_).':';
2758: }
2759: $reply=~s/\:$//;
2760: print $client $reply."\n";
2761: } else {
2762: Reply($client, "refused\n", $userinput);
2763:
2764: }
2765: # ------------------------------------------------------------------- querysend
2766: } elsif ($userinput =~ /^querysend/) {
2767: if (isClient) {
2768: my ($cmd,$query,
2769: $arg1,$arg2,$arg3)=split(/\:/,$userinput);
2770: $query=~s/\n*$//g;
2771: print $client "".
2772: sqlreply("$clientname\&$query".
2773: "\&$arg1"."\&$arg2"."\&$arg3")."\n";
2774: } else {
2775: Reply($client, "refused\n", $userinput);
2776:
2777: }
2778: # ------------------------------------------------------------------ queryreply
2779: } elsif ($userinput =~ /^queryreply/) {
2780: if(isClient) {
2781: my ($cmd,$id,$reply)=split(/:/,$userinput);
2782: my $store;
2783: my $execdir=$perlvar{'lonDaemons'};
2784: if ($store=IO::File->new(">$execdir/tmp/$id")) {
2785: $reply=~s/\&/\n/g;
2786: print $store $reply;
2787: close $store;
2788: my $store2=IO::File->new(">$execdir/tmp/$id.end");
2789: print $store2 "done\n";
2790: close $store2;
2791: print $client "ok\n";
2792: }
2793: else {
2794: print $client "error: ".($!+0)
2795: ." IO::File->new Failed ".
2796: "while attempting queryreply\n";
2797: }
2798: } else {
2799: Reply($client, "refused\n", $userinput);
2800:
2801: }
2802: # ----------------------------------------------------------------- courseidput
2803: } elsif ($userinput =~ /^courseidput/) {
2804: if(isClient) {
2805: my ($cmd,$udom,$what)=split(/:/,$userinput);
2806: chomp($what);
2807: $udom=~s/\W//g;
2808: my $proname=
2809: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
2810: my $now=time;
2811: my @pairs=split(/\&/,$what);
2812: my %hash;
2813: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
2814: foreach my $pair (@pairs) {
2815: my ($key,$value)=split(/=/,$pair);
2816: $hash{$key}=$value.':'.$now;
2817: }
2818: if (untie(%hash)) {
2819: print $client "ok\n";
2820: } else {
2821: print $client "error: ".($!+0)
2822: ." untie(GDBM) Failed ".
2823: "while attempting courseidput\n";
2824: }
2825: } else {
2826: print $client "error: ".($!+0)
2827: ." tie(GDBM) Failed ".
2828: "while attempting courseidput\n";
2829: }
2830: } else {
2831: Reply($client, "refused\n", $userinput);
2832:
2833: }
2834: # ---------------------------------------------------------------- courseiddump
2835: } elsif ($userinput =~ /^courseiddump/) {
2836: if(isClient) {
2837: my ($cmd,$udom,$since,$description)
2838: =split(/:/,$userinput);
2839: if (defined($description)) {
2840: $description=&unescape($description);
2841: } else {
2842: $description='.';
2843: }
2844: unless (defined($since)) { $since=0; }
2845: my $qresult='';
2846: my $proname=
2847: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
2848: my %hash;
2849: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
2850: while (my ($key,$value) = each(%hash)) {
2851: my ($descr,$lasttime)=split(/\:/,$value);
2852: if ($lasttime<$since) { next; }
2853: if ($description eq '.') {
2854: $qresult.=$key.'='.$descr.'&';
2855: } else {
2856: my $unescapeVal = &unescape($descr);
2857: if (eval('$unescapeVal=~/\Q$description\E/i')) {
2858: $qresult.="$key=$descr&";
2859: }
2860: }
2861: }
2862: if (untie(%hash)) {
2863: chop($qresult);
2864: print $client "$qresult\n";
2865: } else {
2866: print $client "error: ".($!+0)
2867: ." untie(GDBM) Failed ".
2868: "while attempting courseiddump\n";
2869: }
2870: } else {
2871: print $client "error: ".($!+0)
2872: ." tie(GDBM) Failed ".
2873: "while attempting courseiddump\n";
2874: }
2875: } else {
2876: Reply($client, "refused\n", $userinput);
2877:
2878: }
2879: # ----------------------------------------------------------------------- idput
2880: } elsif ($userinput =~ /^idput/) {
2881: if(isClient) {
2882: my ($cmd,$udom,$what)=split(/:/,$userinput);
2883: chomp($what);
2884: $udom=~s/\W//g;
2885: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
2886: my $now=time;
2887: {
2888: my $hfh;
2889: if (
2890: $hfh=IO::File->new(">>$proname.hist")
2891: ) { print $hfh "P:$now:$what\n"; }
2892: }
2893: my @pairs=split(/\&/,$what);
2894: my %hash;
2895: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
2896: foreach my $pair (@pairs) {
2897: my ($key,$value)=split(/=/,$pair);
2898: $hash{$key}=$value;
2899: }
2900: if (untie(%hash)) {
2901: print $client "ok\n";
2902: } else {
2903: print $client "error: ".($!+0)
2904: ." untie(GDBM) Failed ".
2905: "while attempting idput\n";
2906: }
2907: } else {
2908: print $client "error: ".($!+0)
2909: ." tie(GDBM) Failed ".
2910: "while attempting idput\n";
2911: }
2912: } else {
2913: Reply($client, "refused\n", $userinput);
2914:
2915: }
2916: # ----------------------------------------------------------------------- idget
2917: } elsif ($userinput =~ /^idget/) {
2918: if(isClient) {
2919: my ($cmd,$udom,$what)=split(/:/,$userinput);
2920: chomp($what);
2921: $udom=~s/\W//g;
2922: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
2923: my @queries=split(/\&/,$what);
2924: my $qresult='';
2925: my %hash;
2926: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
2927: for (my $i=0;$i<=$#queries;$i++) {
2928: $qresult.="$hash{$queries[$i]}&";
2929: }
2930: if (untie(%hash)) {
2931: $qresult=~s/\&$//;
2932: print $client "$qresult\n";
2933: } else {
2934: print $client "error: ".($!+0)
2935: ." untie(GDBM) Failed ".
2936: "while attempting idget\n";
2937: }
2938: } else {
2939: print $client "error: ".($!+0)
2940: ." tie(GDBM) Failed ".
2941: "while attempting idget\n";
2942: }
2943: } else {
2944: Reply($client, "refused\n", $userinput);
2945:
2946: }
2947: # ---------------------------------------------------------------------- tmpput
2948: } elsif ($userinput =~ /^tmpput/) {
2949: if(isClient) {
2950: my ($cmd,$what)=split(/:/,$userinput);
2951: my $store;
2952: $tmpsnum++;
2953: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
2954: $id=~s/\W/\_/g;
2955: $what=~s/\n//g;
2956: my $execdir=$perlvar{'lonDaemons'};
2957: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
2958: print $store $what;
2959: close $store;
2960: print $client "$id\n";
2961: }
2962: else {
2963: print $client "error: ".($!+0)
2964: ."IO::File->new Failed ".
2965: "while attempting tmpput\n";
2966: }
2967: } else {
2968: Reply($client, "refused\n", $userinput);
2969:
2970: }
2971:
2972: # ---------------------------------------------------------------------- tmpget
2973: } elsif ($userinput =~ /^tmpget/) {
2974: if(isClient) {
2975: my ($cmd,$id)=split(/:/,$userinput);
2976: chomp($id);
2977: $id=~s/\W/\_/g;
2978: my $store;
2979: my $execdir=$perlvar{'lonDaemons'};
2980: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
2981: my $reply=<$store>;
2982: print $client "$reply\n";
2983: close $store;
2984: }
2985: else {
2986: print $client "error: ".($!+0)
2987: ."IO::File->new Failed ".
2988: "while attempting tmpget\n";
2989: }
2990: } else {
2991: Reply($client, "refused\n", $userinput);
2992:
2993: }
2994: # ---------------------------------------------------------------------- tmpdel
2995: } elsif ($userinput =~ /^tmpdel/) {
2996: if(isClient) {
2997: my ($cmd,$id)=split(/:/,$userinput);
2998: chomp($id);
2999: $id=~s/\W/\_/g;
3000: my $execdir=$perlvar{'lonDaemons'};
3001: if (unlink("$execdir/tmp/$id.tmp")) {
3002: print $client "ok\n";
3003: } else {
3004: print $client "error: ".($!+0)
3005: ."Unlink tmp Failed ".
3006: "while attempting tmpdel\n";
3007: }
3008: } else {
3009: Reply($client, "refused\n", $userinput);
3010:
3011: }
3012: # -------------------------------------------------------------------------- ls
3013: } elsif ($userinput =~ /^ls/) {
3014: if(isClient) {
3015: my $obs;
3016: my $rights;
3017: my ($cmd,$ulsdir)=split(/:/,$userinput);
3018: my $ulsout='';
3019: my $ulsfn;
3020: if (-e $ulsdir) {
3021: if(-d $ulsdir) {
3022: if (opendir(LSDIR,$ulsdir)) {
3023: while ($ulsfn=readdir(LSDIR)) {
3024: undef $obs, $rights;
3025: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
3026: #We do some obsolete checking here
3027: if(-e $ulsdir.'/'.$ulsfn.".meta") {
3028: open(FILE, $ulsdir.'/'.$ulsfn.".meta");
3029: my @obsolete=<FILE>;
3030: foreach my $obsolete (@obsolete) {
3031: if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }
3032: if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
3033: }
3034: }
3035: $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
3036: if($obs eq '1') { $ulsout.="&1"; }
3037: else { $ulsout.="&0"; }
3038: if($rights eq '1') { $ulsout.="&1:"; }
3039: else { $ulsout.="&0:"; }
3040: }
3041: closedir(LSDIR);
3042: }
3043: } else {
3044: my @ulsstats=stat($ulsdir);
3045: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
3046: }
3047: } else {
3048: $ulsout='no_such_dir';
3049: }
3050: if ($ulsout eq '') { $ulsout='empty'; }
3051: print $client "$ulsout\n";
3052: } else {
3053: Reply($client, "refused\n", $userinput);
3054:
3055: }
3056: # ----------------------------------------------------------------- setannounce
3057: } elsif ($userinput =~ /^setannounce/) {
3058: if (isClient) {
3059: my ($cmd,$announcement)=split(/:/,$userinput);
3060: chomp($announcement);
3061: $announcement=&unescape($announcement);
3062: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
3063: '/announcement.txt')) {
3064: print $store $announcement;
3065: close $store;
3066: print $client "ok\n";
3067: } else {
3068: print $client "error: ".($!+0)."\n";
3069: }
3070: } else {
3071: Reply($client, "refused\n", $userinput);
3072:
3073: }
3074: # ------------------------------------------------------------------ Hanging up
3075: } elsif (($userinput =~ /^exit/) ||
3076: ($userinput =~ /^init/)) { # no restrictions.
3077: &logthis(
3078: "Client $clientip ($clientname) hanging up: $userinput");
3079: print $client "bye\n";
3080: $client->shutdown(2); # shutdown the socket forcibly.
3081: $client->close();
3082: last;
3083:
3084: # ---------------------------------- set current host/domain
3085: } elsif ($userinput =~ /^sethost:/) {
3086: if (isClient) {
3087: print $client &sethost($userinput)."\n";
3088: } else {
3089: print $client "refused\n";
3090: }
3091: #---------------------------------- request file (?) version.
3092: } elsif ($userinput =~/^version:/) {
3093: if (isClient) {
3094: print $client &version($userinput)."\n";
3095: } else {
3096: print $client "refused\n";
3097: }
3098: #------------------------------- is auto-enrollment enabled?
3099: } elsif ($userinput =~/^autorun/) {
3100: if (isClient) {
3101: my $outcome = &localenroll::run();
3102: print $client "$outcome\n";
3103: } else {
3104: print $client "0\n";
3105: }
3106: #------------------------------- get official sections (for auto-enrollment).
3107: } elsif ($userinput =~/^autogetsections/) {
3108: if (isClient) {
3109: my ($cmd,$coursecode)=split(/:/,$userinput);
3110: my @secs = &localenroll::get_sections($coursecode);
3111: my $seclist = &escape(join(':',@secs));
3112: print $client "$seclist\n";
3113: } else {
3114: print $client "refused\n";
3115: }
3116: #----------------------- validate owner of new course section (for auto-enrollment).
3117: } elsif ($userinput =~/^autonewcourse/) {
3118: if (isClient) {
3119: my ($cmd,$course_id,$owner)=split(/:/,$userinput);
3120: my $outcome = &localenroll::new_course($course_id,$owner);
3121: print $client "$outcome\n";
3122: } else {
3123: print $client "refused\n";
3124: }
3125: #-------------- validate course section in schedule of classes (for auto-enrollment).
3126: } elsif ($userinput =~/^autovalidatecourse/) {
3127: if (isClient) {
3128: my ($cmd,$course_id)=split(/:/,$userinput);
3129: my $outcome=&localenroll::validate_courseID($course_id);
3130: print $client "$outcome\n";
3131: } else {
3132: print $client "refused\n";
3133: }
3134: #--------------------------- create password for new user (for auto-enrollment).
3135: } elsif ($userinput =~/^autocreatepassword/) {
3136: if (isClient) {
3137: my ($cmd,$authparam)=split(/:/,$userinput);
3138: my ($create_passwd,$authchk) = @_;
3139: ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam);
3140: print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
3141: } else {
3142: print $client "refused\n";
3143: }
3144: #--------------------------- read and remove temporary files (for auto-enrollment).
3145: } elsif ($userinput =~/^autoretrieve/) {
3146: if (isClient) {
3147: my ($cmd,$filename) = split(/:/,$userinput);
3148: my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
3149: if ( (-e $source) && ($filename ne '') ) {
3150: my $reply = '';
3151: if (open(my $fh,$source)) {
3152: while (<$fh>) {
3153: chomp($_);
3154: $_ =~ s/^\s+//g;
3155: $_ =~ s/\s+$//g;
3156: $reply .= $_;
3157: }
3158: close($fh);
3159: print $client &escape($reply)."\n";
3160: # unlink($source);
3161: } else {
3162: print $client "error\n";
3163: }
3164: } else {
3165: print $client "error\n";
3166: }
3167: } else {
3168: print $client "refused\n";
3169: }
3170: # ------------------------------------------------------------- unknown command
3171:
3172: } else {
3173: # unknown command
3174: print $client "unknown_cmd\n";
3175: }
3176: # -------------------------------------------------------------------- complete
3177: alarm(0);
3178: &status('Listening to '.$clientname);
3179: }
3180: # --------------------------------------------- client unknown or fishy, refuse
3181: } else {
3182: print $client "refused\n";
3183: $client->close();
3184: &logthis("<font color='blue'>WARNING: "
3185: ."Rejected client $clientip, closing connection</font>");
3186: }
3187: }
3188:
3189: # =============================================================================
3190:
3191: &logthis("<font color='red'>CRITICAL: "
3192: ."Disconnect from $clientip ($clientname)</font>");
3193:
3194:
3195: # this exit is VERY important, otherwise the child will become
3196: # a producer of more and more children, forking yourself into
3197: # process death.
3198: exit;
3199:
3200: }
3201:
3202:
3203: #
3204: # Checks to see if the input roleput request was to set
3205: # an author role. If so, invokes the lchtmldir script to set
3206: # up a correct public_html
3207: # Parameters:
3208: # request - The request sent to the rolesput subchunk.
3209: # We're looking for /domain/_au
3210: # domain - The domain in which the user is having roles doctored.
3211: # user - Name of the user for which the role is being put.
3212: # authtype - The authentication type associated with the user.
3213: #
3214: sub ManagePermissions
3215: {
3216:
3217: my ($request, $domain, $user, $authtype) = @_;
3218:
3219: # See if the request is of the form /$domain/_au
3220: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
3221: my $execdir = $perlvar{'lonDaemons'};
3222: my $userhome= "/home/$user" ;
3223: &logthis("system $execdir/lchtmldir $userhome $user $authtype");
3224: system("$execdir/lchtmldir $userhome $user $authtype");
3225: }
3226: }
3227: #
3228: # GetAuthType - Determines the authorization type of a user in a domain.
3229:
3230: # Returns the authorization type or nouser if there is no such user.
3231: #
3232: sub GetAuthType
3233: {
3234:
3235: my ($domain, $user) = @_;
3236:
3237: Debug("GetAuthType( $domain, $user ) \n");
3238: my $proname = &propath($domain, $user);
3239: my $passwdfile = "$proname/passwd";
3240: if( -e $passwdfile ) {
3241: my $pf = IO::File->new($passwdfile);
3242: my $realpassword = <$pf>;
3243: chomp($realpassword);
3244: Debug("Password info = $realpassword\n");
3245: my ($authtype, $contentpwd) = split(/:/, $realpassword);
3246: Debug("Authtype = $authtype, content = $contentpwd\n");
3247: my $availinfo = '';
3248: if($authtype eq 'krb4' or $authtype eq 'krb5') {
3249: $availinfo = $contentpwd;
3250: }
3251:
3252: return "$authtype:$availinfo";
3253: }
3254: else {
3255: Debug("Returning nouser");
3256: return "nouser";
3257: }
3258: }
3259:
3260: sub addline {
3261: my ($fname,$hostid,$ip,$newline)=@_;
3262: my $contents;
3263: my $found=0;
3264: my $expr='^'.$hostid.':'.$ip.':';
3265: $expr =~ s/\./\\\./g;
3266: my $sh;
3267: if ($sh=IO::File->new("$fname.subscription")) {
3268: while (my $subline=<$sh>) {
3269: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
3270: }
3271: $sh->close();
3272: }
3273: $sh=IO::File->new(">$fname.subscription");
3274: if ($contents) { print $sh $contents; }
3275: if ($newline) { print $sh $newline; }
3276: $sh->close();
3277: return $found;
3278: }
3279:
3280: sub getchat {
3281: my ($cdom,$cname,$udom,$uname)=@_;
3282: my %hash;
3283: my $proname=&propath($cdom,$cname);
3284: my @entries=();
3285: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
3286: &GDBM_READER(),0640)) {
3287: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
3288: untie %hash;
3289: }
3290: my @participants=();
3291: my $cutoff=time-60;
3292: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
3293: &GDBM_WRCREAT(),0640)) {
3294: $hash{$uname.':'.$udom}=time;
3295: foreach (sort keys %hash) {
3296: if ($hash{$_}>$cutoff) {
3297: $participants[$#participants+1]='active_participant:'.$_;
3298: }
3299: }
3300: untie %hash;
3301: }
3302: return (@participants,@entries);
3303: }
3304:
3305: sub chatadd {
3306: my ($cdom,$cname,$newchat)=@_;
3307: my %hash;
3308: my $proname=&propath($cdom,$cname);
3309: my @entries=();
3310: my $time=time;
3311: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
3312: &GDBM_WRCREAT(),0640)) {
3313: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
3314: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
3315: my ($thentime,$idnum)=split(/\_/,$lastid);
3316: my $newid=$time.'_000000';
3317: if ($thentime==$time) {
3318: $idnum=~s/^0+//;
3319: $idnum++;
3320: $idnum=substr('000000'.$idnum,-6,6);
3321: $newid=$time.'_'.$idnum;
3322: }
3323: $hash{$newid}=$newchat;
3324: my $expired=$time-3600;
3325: foreach (keys %hash) {
3326: my ($thistime)=($_=~/(\d+)\_/);
3327: if ($thistime<$expired) {
3328: delete $hash{$_};
3329: }
3330: }
3331: untie %hash;
3332: }
3333: {
3334: my $hfh;
3335: if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
3336: print $hfh "$time:".&unescape($newchat)."\n";
3337: }
3338: }
3339: }
3340:
3341: sub unsub {
3342: my ($fname,$clientip)=@_;
3343: my $result;
3344: my $unsubs = 0; # Number of successful unsubscribes:
3345:
3346:
3347: # An old way subscriptions were handled was to have a
3348: # subscription marker file:
3349:
3350: Debug("Attempting unlink of $fname.$clientname");
3351: if (unlink("$fname.$clientname")) {
3352: $unsubs++; # Successful unsub via marker file.
3353: }
3354:
3355: # The more modern way to do it is to have a subscription list
3356: # file:
3357:
3358: if (-e "$fname.subscription") {
3359: my $found=&addline($fname,$clientname,$clientip,'');
3360: if ($found) {
3361: $unsubs++;
3362: }
3363: }
3364:
3365: # If either or both of these mechanisms succeeded in unsubscribing a
3366: # resource we can return ok:
3367:
3368: if($unsubs) {
3369: $result = "ok\n";
3370: } else {
3371: $result = "not_subscribed\n";
3372: }
3373:
3374: return $result;
3375: }
3376:
3377: sub currentversion {
3378: my $fname=shift;
3379: my $version=-1;
3380: my $ulsdir='';
3381: if ($fname=~/^(.+)\/[^\/]+$/) {
3382: $ulsdir=$1;
3383: }
3384: my ($fnamere1,$fnamere2);
3385: # remove version if already specified
3386: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
3387: # get the bits that go before and after the version number
3388: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
3389: $fnamere1=$1;
3390: $fnamere2='.'.$2;
3391: }
3392: if (-e $fname) { $version=1; }
3393: if (-e $ulsdir) {
3394: if(-d $ulsdir) {
3395: if (opendir(LSDIR,$ulsdir)) {
3396: my $ulsfn;
3397: while ($ulsfn=readdir(LSDIR)) {
3398: # see if this is a regular file (ignore links produced earlier)
3399: my $thisfile=$ulsdir.'/'.$ulsfn;
3400: unless (-l $thisfile) {
3401: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) {
3402: if ($1>$version) { $version=$1; }
3403: }
3404: }
3405: }
3406: closedir(LSDIR);
3407: $version++;
3408: }
3409: }
3410: }
3411: return $version;
3412: }
3413:
3414: sub thisversion {
3415: my $fname=shift;
3416: my $version=-1;
3417: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
3418: $version=$1;
3419: }
3420: return $version;
3421: }
3422:
3423: sub subscribe {
3424: my ($userinput,$clientip)=@_;
3425: my $result;
3426: my ($cmd,$fname)=split(/:/,$userinput);
3427: my $ownership=&ishome($fname);
3428: if ($ownership eq 'owner') {
3429: # explitly asking for the current version?
3430: unless (-e $fname) {
3431: my $currentversion=¤tversion($fname);
3432: if (&thisversion($fname)==$currentversion) {
3433: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
3434: my $root=$1;
3435: my $extension=$2;
3436: symlink($root.'.'.$extension,
3437: $root.'.'.$currentversion.'.'.$extension);
3438: unless ($extension=~/\.meta$/) {
3439: symlink($root.'.'.$extension.'.meta',
3440: $root.'.'.$currentversion.'.'.$extension.'.meta');
3441: }
3442: }
3443: }
3444: }
3445: if (-e $fname) {
3446: if (-d $fname) {
3447: $result="directory\n";
3448: } else {
3449: if (-e "$fname.$clientname") {&unsub($fname,$clientip);}
3450: my $now=time;
3451: my $found=&addline($fname,$clientname,$clientip,
3452: "$clientname:$clientip:$now\n");
3453: if ($found) { $result="$fname\n"; }
3454: # if they were subscribed to only meta data, delete that
3455: # subscription, when you subscribe to a file you also get
3456: # the metadata
3457: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
3458: $fname=~s/\/home\/httpd\/html\/res/raw/;
3459: $fname="http://$thisserver/".$fname;
3460: $result="$fname\n";
3461: }
3462: } else {
3463: $result="not_found\n";
3464: }
3465: } else {
3466: $result="rejected\n";
3467: }
3468: return $result;
3469: }
3470:
3471: sub make_passwd_file {
3472: my ($uname, $umode,$npass,$passfilename)=@_;
3473: my $result="ok\n";
3474: if ($umode eq 'krb4' or $umode eq 'krb5') {
3475: {
3476: my $pf = IO::File->new(">$passfilename");
3477: print $pf "$umode:$npass\n";
3478: }
3479: } elsif ($umode eq 'internal') {
3480: my $salt=time;
3481: $salt=substr($salt,6,2);
3482: my $ncpass=crypt($npass,$salt);
3483: {
3484: &Debug("Creating internal auth");
3485: my $pf = IO::File->new(">$passfilename");
3486: print $pf "internal:$ncpass\n";
3487: }
3488: } elsif ($umode eq 'localauth') {
3489: {
3490: my $pf = IO::File->new(">$passfilename");
3491: print $pf "localauth:$npass\n";
3492: }
3493: } elsif ($umode eq 'unix') {
3494: {
3495: #
3496: # Don't allow the creation of privileged accounts!!! that would
3497: # be real bad!!!
3498: #
3499: my $uid = getpwnam($uname);
3500: if((defined $uid) && ($uid == 0)) {
3501: &logthis(">>>Attempted to create privilged account blocked");
3502: return "no_priv_account_error\n";
3503: }
3504:
3505: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
3506: {
3507: &Debug("Executing external: ".$execpath);
3508: &Debug("user = ".$uname.", Password =". $npass);
3509: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
3510: print $se "$uname\n";
3511: print $se "$npass\n";
3512: print $se "$npass\n";
3513: }
3514: my $useraddok = $?;
3515: if($useraddok > 0) {
3516: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
3517: }
3518: my $pf = IO::File->new(">$passfilename");
3519: print $pf "unix:\n";
3520: }
3521: } elsif ($umode eq 'none') {
3522: {
3523: my $pf = IO::File->new(">$passfilename");
3524: print $pf "none:\n";
3525: }
3526: } else {
3527: $result="auth_mode_error\n";
3528: }
3529: return $result;
3530: }
3531:
3532: sub sethost {
3533: my ($remotereq) = @_;
3534: my (undef,$hostid)=split(/:/,$remotereq);
3535: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
3536: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
3537: $currenthostid =$hostid;
3538: $currentdomainid=$hostdom{$hostid};
3539: &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
3540: } else {
3541: &logthis("Requested host id $hostid not an alias of ".
3542: $perlvar{'lonHostID'}." refusing connection");
3543: return 'unable_to_set';
3544: }
3545: return 'ok';
3546: }
3547:
3548: sub version {
3549: my ($userinput)=@_;
3550: $remoteVERSION=(split(/:/,$userinput))[1];
3551: return "version:$VERSION";
3552: }
3553:
3554: #There is a copy of this in lonnet.pm
3555: sub userload {
3556: my $numusers=0;
3557: {
3558: opendir(LONIDS,$perlvar{'lonIDsDir'});
3559: my $filename;
3560: my $curtime=time;
3561: while ($filename=readdir(LONIDS)) {
3562: if ($filename eq '.' || $filename eq '..') {next;}
3563: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
3564: if ($curtime-$mtime < 1800) { $numusers++; }
3565: }
3566: closedir(LONIDS);
3567: }
3568: my $userloadpercent=0;
3569: my $maxuserload=$perlvar{'lonUserLoadLim'};
3570: if ($maxuserload) {
3571: $userloadpercent=100*$numusers/$maxuserload;
3572: }
3573: $userloadpercent=sprintf("%.2f",$userloadpercent);
3574: return $userloadpercent;
3575: }
3576:
3577:
3578: # ----------------------------------- POD (plain old documentation, CPAN style)
3579:
3580: =head1 NAME
3581:
3582: lond - "LON Daemon" Server (port "LOND" 5663)
3583:
3584: =head1 SYNOPSIS
3585:
3586: Usage: B<lond>
3587:
3588: Should only be run as user=www. This is a command-line script which
3589: is invoked by B<loncron>. There is no expectation that a typical user
3590: will manually start B<lond> from the command-line. (In other words,
3591: DO NOT START B<lond> YOURSELF.)
3592:
3593: =head1 DESCRIPTION
3594:
3595: There are two characteristics associated with the running of B<lond>,
3596: PROCESS MANAGEMENT (starting, stopping, handling child processes)
3597: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
3598: subscriptions, etc). These are described in two large
3599: sections below.
3600:
3601: B<PROCESS MANAGEMENT>
3602:
3603: Preforker - server who forks first. Runs as a daemon. HUPs.
3604: Uses IDEA encryption
3605:
3606: B<lond> forks off children processes that correspond to the other servers
3607: in the network. Management of these processes can be done at the
3608: parent process level or the child process level.
3609:
3610: B<logs/lond.log> is the location of log messages.
3611:
3612: The process management is now explained in terms of linux shell commands,
3613: subroutines internal to this code, and signal assignments:
3614:
3615: =over 4
3616:
3617: =item *
3618:
3619: PID is stored in B<logs/lond.pid>
3620:
3621: This is the process id number of the parent B<lond> process.
3622:
3623: =item *
3624:
3625: SIGTERM and SIGINT
3626:
3627: Parent signal assignment:
3628: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
3629:
3630: Child signal assignment:
3631: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
3632: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
3633: to restart a new child.)
3634:
3635: Command-line invocations:
3636: B<kill> B<-s> SIGTERM I<PID>
3637: B<kill> B<-s> SIGINT I<PID>
3638:
3639: Subroutine B<HUNTSMAN>:
3640: This is only invoked for the B<lond> parent I<PID>.
3641: This kills all the children, and then the parent.
3642: The B<lonc.pid> file is cleared.
3643:
3644: =item *
3645:
3646: SIGHUP
3647:
3648: Current bug:
3649: This signal can only be processed the first time
3650: on the parent process. Subsequent SIGHUP signals
3651: have no effect.
3652:
3653: Parent signal assignment:
3654: $SIG{HUP} = \&HUPSMAN;
3655:
3656: Child signal assignment:
3657: none (nothing happens)
3658:
3659: Command-line invocations:
3660: B<kill> B<-s> SIGHUP I<PID>
3661:
3662: Subroutine B<HUPSMAN>:
3663: This is only invoked for the B<lond> parent I<PID>,
3664: This kills all the children, and then the parent.
3665: The B<lond.pid> file is cleared.
3666:
3667: =item *
3668:
3669: SIGUSR1
3670:
3671: Parent signal assignment:
3672: $SIG{USR1} = \&USRMAN;
3673:
3674: Child signal assignment:
3675: $SIG{USR1}= \&logstatus;
3676:
3677: Command-line invocations:
3678: B<kill> B<-s> SIGUSR1 I<PID>
3679:
3680: Subroutine B<USRMAN>:
3681: When invoked for the B<lond> parent I<PID>,
3682: SIGUSR1 is sent to all the children, and the status of
3683: each connection is logged.
3684:
3685: =item *
3686:
3687: SIGUSR2
3688:
3689: Parent Signal assignment:
3690: $SIG{USR2} = \&UpdateHosts
3691:
3692: Child signal assignment:
3693: NONE
3694:
3695:
3696: =item *
3697:
3698: SIGCHLD
3699:
3700: Parent signal assignment:
3701: $SIG{CHLD} = \&REAPER;
3702:
3703: Child signal assignment:
3704: none
3705:
3706: Command-line invocations:
3707: B<kill> B<-s> SIGCHLD I<PID>
3708:
3709: Subroutine B<REAPER>:
3710: This is only invoked for the B<lond> parent I<PID>.
3711: Information pertaining to the child is removed.
3712: The socket port is cleaned up.
3713:
3714: =back
3715:
3716: B<SERVER-SIDE ACTIVITIES>
3717:
3718: Server-side information can be accepted in an encrypted or non-encrypted
3719: method.
3720:
3721: =over 4
3722:
3723: =item ping
3724:
3725: Query a client in the hosts.tab table; "Are you there?"
3726:
3727: =item pong
3728:
3729: Respond to a ping query.
3730:
3731: =item ekey
3732:
3733: Read in encrypted key, make cipher. Respond with a buildkey.
3734:
3735: =item load
3736:
3737: Respond with CPU load based on a computation upon /proc/loadavg.
3738:
3739: =item currentauth
3740:
3741: Reply with current authentication information (only over an
3742: encrypted channel).
3743:
3744: =item auth
3745:
3746: Only over an encrypted channel, reply as to whether a user's
3747: authentication information can be validated.
3748:
3749: =item passwd
3750:
3751: Allow for a password to be set.
3752:
3753: =item makeuser
3754:
3755: Make a user.
3756:
3757: =item passwd
3758:
3759: Allow for authentication mechanism and password to be changed.
3760:
3761: =item home
3762:
3763: Respond to a question "are you the home for a given user?"
3764:
3765: =item update
3766:
3767: Update contents of a subscribed resource.
3768:
3769: =item unsubscribe
3770:
3771: The server is unsubscribing from a resource.
3772:
3773: =item subscribe
3774:
3775: The server is subscribing to a resource.
3776:
3777: =item log
3778:
3779: Place in B<logs/lond.log>
3780:
3781: =item put
3782:
3783: stores hash in namespace
3784:
3785: =item rolesput
3786:
3787: put a role into a user's environment
3788:
3789: =item get
3790:
3791: returns hash with keys from array
3792: reference filled in from namespace
3793:
3794: =item eget
3795:
3796: returns hash with keys from array
3797: reference filled in from namesp (encrypts the return communication)
3798:
3799: =item rolesget
3800:
3801: get a role from a user's environment
3802:
3803: =item del
3804:
3805: deletes keys out of array from namespace
3806:
3807: =item keys
3808:
3809: returns namespace keys
3810:
3811: =item dump
3812:
3813: dumps the complete (or key matching regexp) namespace into a hash
3814:
3815: =item store
3816:
3817: stores hash permanently
3818: for this url; hashref needs to be given and should be a \%hashname; the
3819: remaining args aren't required and if they aren't passed or are '' they will
3820: be derived from the ENV
3821:
3822: =item restore
3823:
3824: returns a hash for a given url
3825:
3826: =item querysend
3827:
3828: Tells client about the lonsql process that has been launched in response
3829: to a sent query.
3830:
3831: =item queryreply
3832:
3833: Accept information from lonsql and make appropriate storage in temporary
3834: file space.
3835:
3836: =item idput
3837:
3838: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
3839: for each student, defined perhaps by the institutional Registrar.)
3840:
3841: =item idget
3842:
3843: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
3844: for each student, defined perhaps by the institutional Registrar.)
3845:
3846: =item tmpput
3847:
3848: Accept and store information in temporary space.
3849:
3850: =item tmpget
3851:
3852: Send along temporarily stored information.
3853:
3854: =item ls
3855:
3856: List part of a user's directory.
3857:
3858: =item pushtable
3859:
3860: Pushes a file in /home/httpd/lonTab directory. Currently limited to:
3861: hosts.tab and domain.tab. The old file is copied to *.tab.backup but
3862: must be restored manually in case of a problem with the new table file.
3863: pushtable requires that the request be encrypted and validated via
3864: ValidateManager. The form of the command is:
3865: enc:pushtable tablename <tablecontents> \n
3866: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
3867: cleartext newline.
3868:
3869: =item Hanging up (exit or init)
3870:
3871: What to do when a client tells the server that they (the client)
3872: are leaving the network.
3873:
3874: =item unknown command
3875:
3876: If B<lond> is sent an unknown command (not in the list above),
3877: it replys to the client "unknown_cmd".
3878:
3879:
3880: =item UNKNOWN CLIENT
3881:
3882: If the anti-spoofing algorithm cannot verify the client,
3883: the client is rejected (with a "refused" message sent
3884: to the client, and the connection is closed.
3885:
3886: =back
3887:
3888: =head1 PREREQUISITES
3889:
3890: IO::Socket
3891: IO::File
3892: Apache::File
3893: Symbol
3894: POSIX
3895: Crypt::IDEA
3896: LWP::UserAgent()
3897: GDBM_File
3898: Authen::Krb4
3899: Authen::Krb5
3900:
3901: =head1 COREQUISITES
3902:
3903: =head1 OSNAMES
3904:
3905: linux
3906:
3907: =head1 SCRIPT CATEGORIES
3908:
3909: Server/Process
3910:
3911: =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