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