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