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