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