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