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