Annotation of loncom/lond, revision 1.411
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 www 4: #
1.411 ! foxr 5: # $Id: lond,v 1.410 2009/01/02 23:07:45 raeburn 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/';
1.325 albertel 34: use LONCAPA;
1.80 harris41 35: use LONCAPA::Configuration;
36:
1.1 albertel 37: use IO::Socket;
38: use IO::File;
1.126 albertel 39: #use Apache::File;
1.1 albertel 40: use POSIX;
41: use Crypt::IDEA;
42: use LWP::UserAgent();
1.347 raeburn 43: use Digest::MD5 qw(md5_hex);
1.3 www 44: use GDBM_File;
45: use Authen::Krb4;
1.91 albertel 46: use Authen::Krb5;
1.49 albertel 47: use localauth;
1.193 raeburn 48: use localenroll;
1.265 albertel 49: use localstudentphoto;
1.143 foxr 50: use File::Copy;
1.292 albertel 51: use File::Find;
1.200 matthew 52: use LONCAPA::lonlocal;
53: use LONCAPA::lonssl;
1.221 albertel 54: use Fcntl qw(:flock);
1.383 raeburn 55: use Apache::lonnet;
1.1 albertel 56:
1.239 foxr 57: my $DEBUG = 0; # Non zero to enable debug log entries.
1.77 foxr 58:
1.57 www 59: my $status='';
60: my $lastlog='';
61:
1.411 ! foxr 62: my $VERSION='$Revision: 1.410 $'; #' stupid emacs
1.121 albertel 63: my $remoteVERSION;
1.214 foxr 64: my $currenthostid="default";
1.115 albertel 65: my $currentdomainid;
1.134 albertel 66:
67: my $client;
1.200 matthew 68: my $clientip; # IP address of client.
69: my $clientname; # LonCAPA name of client.
1.140 foxr 70:
1.134 albertel 71: my $server;
1.200 matthew 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.178 foxr 87: my %managers; # Ip -> manager names
1.161 foxr 88:
1.178 foxr 89: my %perlvar; # Will have the apache conf defined perl vars.
1.134 albertel 90:
1.178 foxr 91: #
1.207 foxr 92: # The hash below is used for command dispatching, and is therefore keyed on the request keyword.
93: # Each element of the hash contains a reference to an array that contains:
94: # A reference to a sub that executes the request corresponding to the keyword.
95: # A flag that is true if the request must be encoded to be acceptable.
96: # A mask with bits as follows:
97: # CLIENT_OK - Set when the function is allowed by ordinary clients
98: # MANAGER_OK - Set when the function is allowed to manager clients.
99: #
100: my $CLIENT_OK = 1;
101: my $MANAGER_OK = 2;
102: my %Dispatcher;
103:
104:
105: #
1.178 foxr 106: # The array below are password error strings."
107: #
108: my $lastpwderror = 13; # Largest error number from lcpasswd.
109: my @passwderrors = ("ok",
1.287 foxr 110: "pwchange_failure - lcpasswd must be run as user 'www'",
111: "pwchange_failure - lcpasswd got incorrect number of arguments",
112: "pwchange_failure - lcpasswd did not get the right nubmer of input text lines",
113: "pwchange_failure - lcpasswd too many simultaneous pwd changes in progress",
114: "pwchange_failure - lcpasswd User does not exist.",
115: "pwchange_failure - lcpasswd Incorrect current passwd",
116: "pwchange_failure - lcpasswd Unable to su to root.",
117: "pwchange_failure - lcpasswd Cannot set new passwd.",
118: "pwchange_failure - lcpasswd Username has invalid characters",
119: "pwchange_failure - lcpasswd Invalid characters in password",
120: "pwchange_failure - lcpasswd User already exists",
121: "pwchange_failure - lcpasswd Something went wrong with user addition.",
122: "pwchange_failure - lcpasswd Password mismatch",
123: "pwchange_failure - lcpasswd Error filename is invalid");
1.97 foxr 124:
125:
1.178 foxr 126: # The array below are lcuseradd error strings.:
1.97 foxr 127:
1.178 foxr 128: my $lastadderror = 13;
129: my @adderrors = ("ok",
130: "User ID mismatch, lcuseradd must run as user www",
131: "lcuseradd Incorrect number of command line parameters must be 3",
132: "lcuseradd Incorrect number of stdinput lines, must be 3",
133: "lcuseradd Too many other simultaneous pwd changes in progress",
134: "lcuseradd User does not exist",
135: "lcuseradd Unable to make www member of users's group",
136: "lcuseradd Unable to su to root",
137: "lcuseradd Unable to set password",
1.377 albertel 138: "lcuseradd Username has invalid characters",
1.178 foxr 139: "lcuseradd Password has an invalid character",
140: "lcuseradd User already exists",
141: "lcuseradd Could not add user.",
142: "lcuseradd Password mismatch");
1.97 foxr 143:
1.96 foxr 144:
1.207 foxr 145:
146: #
147: # Statistics that are maintained and dislayed in the status line.
148: #
1.212 foxr 149: my $Transactions = 0; # Number of attempted transactions.
150: my $Failures = 0; # Number of transcations failed.
1.207 foxr 151:
152: # ResetStatistics:
153: # Resets the statistics counters:
154: #
155: sub ResetStatistics {
156: $Transactions = 0;
157: $Failures = 0;
158: }
159:
1.200 matthew 160: #------------------------------------------------------------------------
161: #
162: # LocalConnection
163: # Completes the formation of a locally authenticated connection.
164: # This function will ensure that the 'remote' client is really the
165: # local host. If not, the connection is closed, and the function fails.
166: # If so, initcmd is parsed for the name of a file containing the
167: # IDEA session key. The fie is opened, read, deleted and the session
168: # key returned to the caller.
169: #
170: # Parameters:
171: # $Socket - Socket open on client.
172: # $initcmd - The full text of the init command.
173: #
174: # Returns:
175: # IDEA session key on success.
176: # undef on failure.
177: #
178: sub LocalConnection {
179: my ($Socket, $initcmd) = @_;
1.373 albertel 180: Debug("Attempting local connection: $initcmd client: $clientip");
1.277 albertel 181: if($clientip ne "127.0.0.1") {
1.200 matthew 182: &logthis('<font color="red"> LocalConnection rejecting non local: '
1.373 albertel 183: ."$clientip ne 127.0.0.1 </font>");
1.200 matthew 184: close $Socket;
185: return undef;
1.224 foxr 186: } else {
1.200 matthew 187: chomp($initcmd); # Get rid of \n in filename.
188: my ($init, $type, $name) = split(/:/, $initcmd);
189: Debug(" Init command: $init $type $name ");
190:
191: # Require that $init = init, and $type = local: Otherwise
192: # the caller is insane:
193:
194: if(($init ne "init") && ($type ne "local")) {
195: &logthis('<font color = "red"> LocalConnection: caller is insane! '
196: ."init = $init, and type = $type </font>");
197: close($Socket);;
198: return undef;
199:
200: }
201: # Now get the key filename:
202:
203: my $IDEAKey = lonlocal::ReadKeyFile($name);
204: return $IDEAKey;
205: }
206: }
207: #------------------------------------------------------------------------------
208: #
209: # SSLConnection
210: # Completes the formation of an ssh authenticated connection. The
211: # socket is promoted to an ssl socket. If this promotion and the associated
212: # certificate exchange are successful, the IDEA key is generated and sent
213: # to the remote peer via the SSL tunnel. The IDEA key is also returned to
214: # the caller after the SSL tunnel is torn down.
215: #
216: # Parameters:
217: # Name Type Purpose
218: # $Socket IO::Socket::INET Plaintext socket.
219: #
220: # Returns:
221: # IDEA key on success.
222: # undef on failure.
223: #
224: sub SSLConnection {
225: my $Socket = shift;
226:
227: Debug("SSLConnection: ");
228: my $KeyFile = lonssl::KeyFile();
229: if(!$KeyFile) {
230: my $err = lonssl::LastError();
231: &logthis("<font color=\"red\"> CRITICAL"
232: ."Can't get key file $err </font>");
233: return undef;
234: }
235: my ($CACertificate,
236: $Certificate) = lonssl::CertificateFile();
237:
238:
239: # If any of the key, certificate or certificate authority
240: # certificate filenames are not defined, this can't work.
241:
242: if((!$Certificate) || (!$CACertificate)) {
243: my $err = lonssl::LastError();
244: &logthis("<font color=\"red\"> CRITICAL"
245: ."Can't get certificates: $err </font>");
246:
247: return undef;
248: }
249: Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate");
250:
251: # Indicate to our peer that we can procede with
252: # a transition to ssl authentication:
253:
254: print $Socket "ok:ssl\n";
255:
256: Debug("Approving promotion -> ssl");
257: # And do so:
258:
259: my $SSLSocket = lonssl::PromoteServerSocket($Socket,
260: $CACertificate,
261: $Certificate,
262: $KeyFile);
263: if(! ($SSLSocket) ) { # SSL socket promotion failed.
264: my $err = lonssl::LastError();
265: &logthis("<font color=\"red\"> CRITICAL "
266: ."SSL Socket promotion failed: $err </font>");
267: return undef;
268: }
269: Debug("SSL Promotion successful");
270:
271: #
272: # The only thing we'll use the socket for is to send the IDEA key
273: # to the peer:
274:
275: my $Key = lonlocal::CreateCipherKey();
276: print $SSLSocket "$Key\n";
277:
278: lonssl::Close($SSLSocket);
279:
280: Debug("Key exchange complete: $Key");
281:
282: return $Key;
283: }
284: #
285: # InsecureConnection:
286: # If insecure connections are allowd,
287: # exchange a challenge with the client to 'validate' the
288: # client (not really, but that's the protocol):
289: # We produce a challenge string that's sent to the client.
290: # The client must then echo the challenge verbatim to us.
291: #
292: # Parameter:
293: # Socket - Socket open on the client.
294: # Returns:
295: # 1 - success.
296: # 0 - failure (e.g.mismatch or insecure not allowed).
297: #
298: sub InsecureConnection {
299: my $Socket = shift;
300:
301: # Don't even start if insecure connections are not allowed.
302:
303: if(! $perlvar{londAllowInsecure}) { # Insecure connections not allowed.
304: return 0;
305: }
306:
307: # Fabricate a challenge string and send it..
308:
309: my $challenge = "$$".time; # pid + time.
310: print $Socket "$challenge\n";
311: &status("Waiting for challenge reply");
312:
313: my $answer = <$Socket>;
314: $answer =~s/\W//g;
315: if($challenge eq $answer) {
316: return 1;
1.224 foxr 317: } else {
1.200 matthew 318: logthis("<font color='blue'>WARNING client did not respond to challenge</font>");
319: &status("No challenge reqply");
320: return 0;
321: }
322:
323:
324: }
1.251 foxr 325: #
326: # Safely execute a command (as long as it's not a shel command and doesn
327: # not require/rely on shell escapes. The function operates by doing a
328: # a pipe based fork and capturing stdout and stderr from the pipe.
329: #
330: # Formal Parameters:
331: # $line - A line of text to be executed as a command.
332: # Returns:
333: # The output from that command. If the output is multiline the caller
334: # must know how to split up the output.
335: #
336: #
337: sub execute_command {
338: my ($line) = @_;
339: my @words = split(/\s/, $line); # Bust the command up into words.
340: my $output = "";
341:
342: my $pid = open(CHILD, "-|");
343:
344: if($pid) { # Parent process
345: Debug("In parent process for execute_command");
346: my @data = <CHILD>; # Read the child's outupt...
347: close CHILD;
348: foreach my $output_line (@data) {
349: Debug("Adding $output_line");
350: $output .= $output_line; # Presumably has a \n on it.
351: }
352:
353: } else { # Child process
354: close (STDERR);
355: open (STDERR, ">&STDOUT");# Combine stderr, and stdout...
356: exec(@words); # won't return.
357: }
358: return $output;
359: }
360:
1.200 matthew 361:
1.140 foxr 362: # GetCertificate: Given a transaction that requires a certificate,
363: # this function will extract the certificate from the transaction
364: # request. Note that at this point, the only concept of a certificate
365: # is the hostname to which we are connected.
366: #
367: # Parameter:
368: # request - The request sent by our client (this parameterization may
369: # need to change when we really use a certificate granting
370: # authority.
371: #
372: sub GetCertificate {
373: my $request = shift;
374:
375: return $clientip;
376: }
1.161 foxr 377:
1.178 foxr 378: #
379: # Return true if client is a manager.
380: #
381: sub isManager {
382: return (($ConnectionType eq "manager") || ($ConnectionType eq "both"));
383: }
384: #
385: # Return tru if client can do client functions
386: #
387: sub isClient {
388: return (($ConnectionType eq "client") || ($ConnectionType eq "both"));
389: }
1.161 foxr 390:
391:
1.156 foxr 392: #
393: # ReadManagerTable: Reads in the current manager table. For now this is
394: # done on each manager authentication because:
395: # - These authentications are not frequent
396: # - This allows dynamic changes to the manager table
397: # without the need to signal to the lond.
398: #
399: sub ReadManagerTable {
400:
401: # Clean out the old table first..
402:
1.166 foxr 403: foreach my $key (keys %managers) {
404: delete $managers{$key};
405: }
406:
407: my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
408: if (!open (MANAGERS, $tablename)) {
409: logthis('<font color="red">No manager table. Nobody can manage!!</font>');
410: return;
411: }
412: while(my $host = <MANAGERS>) {
413: chomp($host);
414: if ($host =~ "^#") { # Comment line.
415: next;
416: }
1.368 albertel 417: if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member
1.161 foxr 418: # The entry is of the form:
419: # cluname:hostname
420: # cluname - A 'cluster hostname' is needed in order to negotiate
421: # the host key.
422: # hostname- The dns name of the host.
423: #
1.166 foxr 424: my($cluname, $dnsname) = split(/:/, $host);
425:
426: my $ip = gethostbyname($dnsname);
427: if(defined($ip)) { # bad names don't deserve entry.
428: my $hostip = inet_ntoa($ip);
429: $managers{$hostip} = $cluname;
430: logthis('<font color="green"> registering manager '.
431: "$dnsname as $cluname with $hostip </font>\n");
432: }
433: } else {
434: logthis('<font color="green"> existing host'." $host</font>\n");
1.368 albertel 435: $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber
1.166 foxr 436: }
437: }
1.156 foxr 438: }
1.140 foxr 439:
440: #
441: # ValidManager: Determines if a given certificate represents a valid manager.
442: # in this primitive implementation, the 'certificate' is
443: # just the connecting loncapa client name. This is checked
444: # against a valid client list in the configuration.
445: #
446: #
447: sub ValidManager {
448: my $certificate = shift;
449:
1.163 foxr 450: return isManager;
1.140 foxr 451: }
452: #
1.143 foxr 453: # CopyFile: Called as part of the process of installing a
454: # new configuration file. This function copies an existing
455: # file to a backup file.
456: # Parameters:
457: # oldfile - Name of the file to backup.
458: # newfile - Name of the backup file.
459: # Return:
460: # 0 - Failure (errno has failure reason).
461: # 1 - Success.
462: #
463: sub CopyFile {
1.192 foxr 464:
465: my ($oldfile, $newfile) = @_;
1.143 foxr 466:
1.281 matthew 467: if (! copy($oldfile,$newfile)) {
468: return 0;
1.143 foxr 469: }
1.281 matthew 470: chmod(0660, $newfile);
471: return 1;
1.143 foxr 472: }
1.157 foxr 473: #
474: # Host files are passed out with externally visible host IPs.
475: # If, for example, we are behind a fire-wall or NAT host, our
476: # internally visible IP may be different than the externally
477: # visible IP. Therefore, we always adjust the contents of the
478: # host file so that the entry for ME is the IP that we believe
479: # we have. At present, this is defined as the entry that
480: # DNS has for us. If by some chance we are not able to get a
481: # DNS translation for us, then we assume that the host.tab file
482: # is correct.
483: # BUGBUGBUG - in the future, we really should see if we can
484: # easily query the interface(s) instead.
485: # Parameter(s):
486: # contents - The contents of the host.tab to check.
487: # Returns:
488: # newcontents - The adjusted contents.
489: #
490: #
491: sub AdjustHostContents {
492: my $contents = shift;
493: my $adjusted;
494: my $me = $perlvar{'lonHostID'};
495:
1.354 albertel 496: foreach my $line (split(/\n/,$contents)) {
1.157 foxr 497: if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
498: chomp($line);
499: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
500: if ($id eq $me) {
1.354 albertel 501: my $ip = gethostbyname($name);
502: my $ipnew = inet_ntoa($ip);
503: $ip = $ipnew;
1.157 foxr 504: # Reconstruct the host line and append to adjusted:
505:
1.354 albertel 506: my $newline = "$id:$domain:$role:$name:$ip";
507: if($maxcon ne "") { # Not all hosts have loncnew tuning params
508: $newline .= ":$maxcon:$idleto:$mincon";
509: }
510: $adjusted .= $newline."\n";
1.157 foxr 511:
1.354 albertel 512: } else { # Not me, pass unmodified.
513: $adjusted .= $line."\n";
514: }
1.157 foxr 515: } else { # Blank or comment never re-written.
516: $adjusted .= $line."\n"; # Pass blanks and comments as is.
517: }
1.354 albertel 518: }
519: return $adjusted;
1.157 foxr 520: }
1.143 foxr 521: #
522: # InstallFile: Called to install an administrative file:
523: # - The file is created with <name>.tmp
524: # - The <name>.tmp file is then mv'd to <name>
525: # This lugubrious procedure is done to ensure that we are never without
526: # a valid, even if dated, version of the file regardless of who crashes
527: # and when the crash occurs.
528: #
529: # Parameters:
530: # Name of the file
531: # File Contents.
532: # Return:
533: # nonzero - success.
534: # 0 - failure and $! has an errno.
535: #
536: sub InstallFile {
1.192 foxr 537:
538: my ($Filename, $Contents) = @_;
1.143 foxr 539: my $TempFile = $Filename.".tmp";
540:
541: # Open the file for write:
542:
543: my $fh = IO::File->new("> $TempFile"); # Write to temp.
544: if(!(defined $fh)) {
545: &logthis('<font color="red"> Unable to create '.$TempFile."</font>");
546: return 0;
547: }
548: # write the contents of the file:
549:
550: print $fh ($Contents);
551: $fh->close; # In case we ever have a filesystem w. locking
552:
553: chmod(0660, $TempFile);
554:
555: # Now we can move install the file in position.
556:
557: move($TempFile, $Filename);
558:
559: return 1;
560: }
1.200 matthew 561:
562:
1.169 foxr 563: #
564: # ConfigFileFromSelector: converts a configuration file selector
1.411 ! foxr 565: # into a configuration file pathname.
! 566: # It's probably no longer necessary to preserve
! 567: # special handling of hosts or domain as those
! 568: # files have been superceded by dns_hosts, dns_domain.
! 569: # The default action is just to prepend the directory
! 570: # and append .tab
! 571: #
1.169 foxr 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 {
1.411 ! foxr 588: $tablefile = $tabledir.$selector.'.tab';
1.169 foxr 589: }
590: return $tablefile;
1.143 foxr 591:
1.169 foxr 592: }
1.143 foxr 593: #
1.141 foxr 594: # PushFile: Called to do an administrative push of a file.
595: # - Ensure the file being pushed is one we support.
596: # - Backup the old file to <filename.saved>
597: # - Separate the contents of the new file out from the
598: # rest of the request.
599: # - Write the new file.
600: # Parameter:
601: # Request - The entire user request. This consists of a : separated
602: # string pushfile:tablename:contents.
603: # NOTE: The contents may have :'s in it as well making things a bit
604: # more interesting... but not much.
605: # Returns:
606: # String to send to client ("ok" or "refused" if bad file).
607: #
608: sub PushFile {
609: my $request = shift;
610: my ($command, $filename, $contents) = split(":", $request, 3);
611:
612: # At this point in time, pushes for only the following tables are
613: # supported:
614: # hosts.tab ($filename eq host).
615: # domain.tab ($filename eq domain).
616: # Construct the destination filename or reject the request.
617: #
618: # lonManage is supposed to ensure this, however this session could be
619: # part of some elaborate spoof that managed somehow to authenticate.
620: #
621:
1.169 foxr 622:
623: my $tablefile = ConfigFileFromSelector($filename);
624: if(! (defined $tablefile)) {
1.141 foxr 625: return "refused";
626: }
627: #
628: # >copy< the old table to the backup table
629: # don't rename in case system crashes/reboots etc. in the time
630: # window between a rename and write.
631: #
632: my $backupfile = $tablefile;
633: $backupfile =~ s/\.tab$/.old/;
1.143 foxr 634: if(!CopyFile($tablefile, $backupfile)) {
635: &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
636: return "error:$!";
637: }
1.141 foxr 638: &logthis('<font color="green"> Pushfile: backed up '
639: .$tablefile." to $backupfile</font>");
640:
1.157 foxr 641: # If the file being pushed is the host file, we adjust the entry for ourself so that the
642: # IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible
643: # to conceive of conditions where we don't have a DNS entry locally. This is possible in a
644: # network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now)
645: # that possibilty.
646:
647: if($filename eq "host") {
648: $contents = AdjustHostContents($contents);
649: }
650:
1.141 foxr 651: # Install the new file:
652:
1.143 foxr 653: if(!InstallFile($tablefile, $contents)) {
654: &logthis('<font color="red"> Pushfile: unable to install '
1.145 foxr 655: .$tablefile." $! </font>");
1.143 foxr 656: return "error:$!";
1.224 foxr 657: } else {
1.143 foxr 658: &logthis('<font color="green"> Installed new '.$tablefile
659: ."</font>");
660:
661: }
662:
1.141 foxr 663:
664: # Indicate success:
665:
666: return "ok";
667:
668: }
1.145 foxr 669:
670: #
671: # Called to re-init either lonc or lond.
672: #
673: # Parameters:
674: # request - The full request by the client. This is of the form
675: # reinit:<process>
676: # where <process> is allowed to be either of
677: # lonc or lond
678: #
679: # Returns:
680: # The string to be sent back to the client either:
681: # ok - Everything worked just fine.
682: # error:why - There was a failure and why describes the reason.
683: #
684: #
685: sub ReinitProcess {
686: my $request = shift;
687:
1.146 foxr 688:
689: # separate the request (reinit) from the process identifier and
690: # validate it producing the name of the .pid file for the process.
691: #
692: #
693: my ($junk, $process) = split(":", $request);
1.147 foxr 694: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
1.146 foxr 695: if($process eq 'lonc') {
696: $processpidfile = $processpidfile."lonc.pid";
1.147 foxr 697: if (!open(PIDFILE, "< $processpidfile")) {
698: return "error:Open failed for $processpidfile";
699: }
700: my $loncpid = <PIDFILE>;
701: close(PIDFILE);
702: logthis('<font color="red"> Reinitializing lonc pid='.$loncpid
703: ."</font>");
704: kill("USR2", $loncpid);
1.146 foxr 705: } elsif ($process eq 'lond') {
1.147 foxr 706: logthis('<font color="red"> Reinitializing self (lond) </font>');
707: &UpdateHosts; # Lond is us!!
1.146 foxr 708: } else {
709: &logthis('<font color="yellow" Invalid reinit request for '.$process
710: ."</font>");
711: return "error:Invalid process identifier $process";
712: }
1.145 foxr 713: return 'ok';
714: }
1.168 foxr 715: # Validate a line in a configuration file edit script:
716: # Validation includes:
717: # - Ensuring the command is valid.
718: # - Ensuring the command has sufficient parameters
719: # Parameters:
720: # scriptline - A line to validate (\n has been stripped for what it's worth).
1.167 foxr 721: #
1.168 foxr 722: # Return:
723: # 0 - Invalid scriptline.
724: # 1 - Valid scriptline
725: # NOTE:
726: # Only the command syntax is checked, not the executability of the
727: # command.
728: #
729: sub isValidEditCommand {
730: my $scriptline = shift;
731:
732: # Line elements are pipe separated:
733:
734: my ($command, $key, $newline) = split(/\|/, $scriptline);
735: &logthis('<font color="green"> isValideditCommand checking: '.
736: "Command = '$command', Key = '$key', Newline = '$newline' </font>\n");
737:
738: if ($command eq "delete") {
739: #
740: # key with no newline.
741: #
742: if( ($key eq "") || ($newline ne "")) {
743: return 0; # Must have key but no newline.
744: } else {
745: return 1; # Valid syntax.
746: }
1.169 foxr 747: } elsif ($command eq "replace") {
1.168 foxr 748: #
749: # key and newline:
750: #
751: if (($key eq "") || ($newline eq "")) {
752: return 0;
753: } else {
754: return 1;
755: }
1.169 foxr 756: } elsif ($command eq "append") {
757: if (($key ne "") && ($newline eq "")) {
758: return 1;
759: } else {
760: return 0;
761: }
1.168 foxr 762: } else {
763: return 0; # Invalid command.
764: }
765: return 0; # Should not get here!!!
766: }
1.169 foxr 767: #
768: # ApplyEdit - Applies an edit command to a line in a configuration
769: # file. It is the caller's responsiblity to validate the
770: # edit line.
771: # Parameters:
772: # $directive - A single edit directive to apply.
773: # Edit directives are of the form:
774: # append|newline - Appends a new line to the file.
775: # replace|key|newline - Replaces the line with key value 'key'
776: # delete|key - Deletes the line with key value 'key'.
777: # $editor - A config file editor object that contains the
778: # file being edited.
779: #
780: sub ApplyEdit {
1.192 foxr 781:
782: my ($directive, $editor) = @_;
1.169 foxr 783:
784: # Break the directive down into its command and its parameters
785: # (at most two at this point. The meaning of the parameters, if in fact
786: # they exist depends on the command).
787:
788: my ($command, $p1, $p2) = split(/\|/, $directive);
789:
790: if($command eq "append") {
791: $editor->Append($p1); # p1 - key p2 null.
792: } elsif ($command eq "replace") {
793: $editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline.
794: } elsif ($command eq "delete") {
795: $editor->DeleteLine($p1); # p1 - key p2 null.
796: } else { # Should not get here!!!
797: die "Invalid command given to ApplyEdit $command"
798: }
799: }
800: #
801: # AdjustOurHost:
802: # Adjusts a host file stored in a configuration file editor object
803: # for the true IP address of this host. This is necessary for hosts
804: # that live behind a firewall.
805: # Those hosts have a publicly distributed IP of the firewall, but
806: # internally must use their actual IP. We assume that a given
807: # host only has a single IP interface for now.
808: # Formal Parameters:
809: # editor - The configuration file editor to adjust. This
810: # editor is assumed to contain a hosts.tab file.
811: # Strategy:
812: # - Figure out our hostname.
813: # - Lookup the entry for this host.
814: # - Modify the line to contain our IP
815: # - Do a replace for this host.
816: sub AdjustOurHost {
817: my $editor = shift;
818:
819: # figure out who I am.
820:
821: my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname.
822:
823: # Get my host file entry.
824:
825: my $ConfigLine = $editor->Find($myHostName);
826: if(! (defined $ConfigLine)) {
827: die "AdjustOurHost - no entry for me in hosts file $myHostName";
828: }
829: # figure out my IP:
830: # Use the config line to get my hostname.
831: # Use gethostbyname to translate that into an IP address.
832: #
1.338 albertel 833: my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
1.169 foxr 834: #
835: # Reassemble the config line from the elements in the list.
836: # Note that if the loncnew items were not present before, they will
837: # be now even if they would be empty
838: #
839: my $newConfigLine = $id;
1.338 albertel 840: foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) {
1.169 foxr 841: $newConfigLine .= ":".$item;
842: }
843: # Replace the line:
844:
845: $editor->ReplaceLine($id, $newConfigLine);
846:
847: }
848: #
849: # ReplaceConfigFile:
850: # Replaces a configuration file with the contents of a
851: # configuration file editor object.
852: # This is done by:
853: # - Copying the target file to <filename>.old
854: # - Writing the new file to <filename>.tmp
855: # - Moving <filename.tmp> -> <filename>
856: # This laborious process ensures that the system is never without
857: # a configuration file that's at least valid (even if the contents
858: # may be dated).
859: # Parameters:
860: # filename - Name of the file to modify... this is a full path.
861: # editor - Editor containing the file.
862: #
863: sub ReplaceConfigFile {
1.192 foxr 864:
865: my ($filename, $editor) = @_;
1.168 foxr 866:
1.169 foxr 867: CopyFile ($filename, $filename.".old");
868:
869: my $contents = $editor->Get(); # Get the contents of the file.
870:
871: InstallFile($filename, $contents);
872: }
1.168 foxr 873: #
874: #
875: # Called to edit a configuration table file
1.167 foxr 876: # Parameters:
877: # request - The entire command/request sent by lonc or lonManage
878: # Return:
879: # The reply to send to the client.
1.168 foxr 880: #
1.167 foxr 881: sub EditFile {
882: my $request = shift;
883:
884: # Split the command into it's pieces: edit:filetype:script
885:
1.339 albertel 886: my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script
1.167 foxr 887:
888: # Check the pre-coditions for success:
889:
1.339 albertel 890: if($cmd != "edit") { # Something is amiss afoot alack.
1.167 foxr 891: return "error:edit request detected, but request != 'edit'\n";
892: }
893: if( ($filetype ne "hosts") &&
894: ($filetype ne "domain")) {
895: return "error:edit requested with invalid file specifier: $filetype \n";
896: }
897:
898: # Split the edit script and check it's validity.
1.168 foxr 899:
900: my @scriptlines = split(/\n/, $script); # one line per element.
901: my $linecount = scalar(@scriptlines);
902: for(my $i = 0; $i < $linecount; $i++) {
903: chomp($scriptlines[$i]);
904: if(!isValidEditCommand($scriptlines[$i])) {
905: return "error:edit with bad script line: '$scriptlines[$i]' \n";
906: }
907: }
1.145 foxr 908:
1.167 foxr 909: # Execute the edit operation.
1.169 foxr 910: # - Create a config file editor for the appropriate file and
911: # - execute each command in the script:
912: #
913: my $configfile = ConfigFileFromSelector($filetype);
914: if (!(defined $configfile)) {
915: return "refused\n";
916: }
917: my $editor = ConfigFileEdit->new($configfile);
1.167 foxr 918:
1.169 foxr 919: for (my $i = 0; $i < $linecount; $i++) {
920: ApplyEdit($scriptlines[$i], $editor);
921: }
922: # If the file is the host file, ensure that our host is
923: # adjusted to have our ip:
924: #
925: if($filetype eq "host") {
926: AdjustOurHost($editor);
927: }
928: # Finally replace the current file with our file.
929: #
930: ReplaceConfigFile($configfile, $editor);
1.167 foxr 931:
932: return "ok\n";
933: }
1.207 foxr 934:
1.255 foxr 935: # read_profile
936: #
937: # Returns a set of specific entries from a user's profile file.
938: # this is a utility function that is used by both get_profile_entry and
939: # get_profile_entry_encrypted.
940: #
941: # Parameters:
942: # udom - Domain in which the user exists.
943: # uname - User's account name (loncapa account)
944: # namespace - The profile namespace to open.
945: # what - A set of & separated queries.
946: # Returns:
947: # If all ok: - The string that needs to be shipped back to the user.
948: # If failure - A string that starts with error: followed by the failure
949: # reason.. note that this probabyl gets shipped back to the
950: # user as well.
951: #
952: sub read_profile {
953: my ($udom, $uname, $namespace, $what) = @_;
954:
955: my $hashref = &tie_user_hash($udom, $uname, $namespace,
956: &GDBM_READER());
957: if ($hashref) {
958: my @queries=split(/\&/,$what);
959: my $qresult='';
960:
961: for (my $i=0;$i<=$#queries;$i++) {
962: $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.
963: }
964: $qresult=~s/\&$//; # Remove trailing & from last lookup.
1.311 albertel 965: if (&untie_user_hash($hashref)) {
1.255 foxr 966: return $qresult;
967: } else {
968: return "error: ".($!+0)." untie (GDBM) Failed";
969: }
970: } else {
971: if ($!+0 == 2) {
972: return "error:No such file or GDBM reported bad block error";
973: } else {
974: return "error: ".($!+0)." tie (GDBM) Failed";
975: }
976: }
977:
978: }
1.214 foxr 979: #--------------------- Request Handlers --------------------------------------------
980: #
1.215 foxr 981: # By convention each request handler registers itself prior to the sub
982: # declaration:
1.214 foxr 983: #
984:
1.216 foxr 985: #++
986: #
1.214 foxr 987: # Handles ping requests.
988: # Parameters:
989: # $cmd - the actual keyword that invoked us.
990: # $tail - the tail of the request that invoked us.
991: # $replyfd- File descriptor connected to the client
992: # Implicit Inputs:
993: # $currenthostid - Global variable that carries the name of the host we are
994: # known as.
995: # Returns:
996: # 1 - Ok to continue processing.
997: # 0 - Program should exit.
998: # Side effects:
999: # Reply information is sent to the client.
1000: sub ping_handler {
1001: my ($cmd, $tail, $client) = @_;
1002: Debug("$cmd $tail $client .. $currenthostid:");
1003:
1.387 albertel 1004: Reply( $client,\$currenthostid,"$cmd:$tail");
1.214 foxr 1005:
1006: return 1;
1007: }
1008: ®ister_handler("ping", \&ping_handler, 0, 1, 1); # Ping unencoded, client or manager.
1009:
1.216 foxr 1010: #++
1.215 foxr 1011: #
1012: # Handles pong requests. Pong replies with our current host id, and
1013: # the results of a ping sent to us via our lonc.
1014: #
1015: # Parameters:
1016: # $cmd - the actual keyword that invoked us.
1017: # $tail - the tail of the request that invoked us.
1018: # $replyfd- File descriptor connected to the client
1019: # Implicit Inputs:
1020: # $currenthostid - Global variable that carries the name of the host we are
1021: # connected to.
1022: # Returns:
1023: # 1 - Ok to continue processing.
1024: # 0 - Program should exit.
1025: # Side effects:
1026: # Reply information is sent to the client.
1027: sub pong_handler {
1028: my ($cmd, $tail, $replyfd) = @_;
1029:
1.365 albertel 1030: my $reply=&Apache::lonnet::reply("ping",$clientname);
1.215 foxr 1031: &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");
1032: return 1;
1033: }
1034: ®ister_handler("pong", \&pong_handler, 0, 1, 1); # Pong unencoded, client or manager
1035:
1.216 foxr 1036: #++
1037: # Called to establish an encrypted session key with the remote client.
1038: # Note that with secure lond, in most cases this function is never
1039: # invoked. Instead, the secure session key is established either
1040: # via a local file that's locked down tight and only lives for a short
1041: # time, or via an ssl tunnel...and is generated from a bunch-o-random
1042: # bits from /dev/urandom, rather than the predictable pattern used by
1043: # by this sub. This sub is only used in the old-style insecure
1044: # key negotiation.
1045: # Parameters:
1046: # $cmd - the actual keyword that invoked us.
1047: # $tail - the tail of the request that invoked us.
1048: # $replyfd- File descriptor connected to the client
1049: # Implicit Inputs:
1050: # $currenthostid - Global variable that carries the name of the host
1051: # known as.
1052: # $clientname - Global variable that carries the name of the hsot we're connected to.
1053: # Returns:
1054: # 1 - Ok to continue processing.
1055: # 0 - Program should exit.
1056: # Implicit Outputs:
1057: # Reply information is sent to the client.
1058: # $cipher is set with a reference to a new IDEA encryption object.
1059: #
1060: sub establish_key_handler {
1061: my ($cmd, $tail, $replyfd) = @_;
1062:
1063: my $buildkey=time.$$.int(rand 100000);
1064: $buildkey=~tr/1-6/A-F/;
1065: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
1066: my $key=$currenthostid.$clientname;
1067: $key=~tr/a-z/A-Z/;
1068: $key=~tr/G-P/0-9/;
1069: $key=~tr/Q-Z/0-9/;
1070: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
1071: $key=substr($key,0,32);
1072: my $cipherkey=pack("H32",$key);
1073: $cipher=new IDEA $cipherkey;
1.387 albertel 1074: &Reply($replyfd, \$buildkey, "$cmd:$tail");
1.216 foxr 1075:
1076: return 1;
1077:
1078: }
1079: ®ister_handler("ekey", \&establish_key_handler, 0, 1,1);
1080:
1.217 foxr 1081: # Handler for the load command. Returns the current system load average
1082: # to the requestor.
1083: #
1084: # Parameters:
1085: # $cmd - the actual keyword that invoked us.
1086: # $tail - the tail of the request that invoked us.
1087: # $replyfd- File descriptor connected to the client
1088: # Implicit Inputs:
1089: # $currenthostid - Global variable that carries the name of the host
1090: # known as.
1091: # $clientname - Global variable that carries the name of the hsot we're connected to.
1092: # Returns:
1093: # 1 - Ok to continue processing.
1094: # 0 - Program should exit.
1095: # Side effects:
1096: # Reply information is sent to the client.
1097: sub load_handler {
1098: my ($cmd, $tail, $replyfd) = @_;
1099:
1100: # Get the load average from /proc/loadavg and calculate it as a percentage of
1101: # the allowed load limit as set by the perl global variable lonLoadLim
1102:
1103: my $loadavg;
1104: my $loadfile=IO::File->new('/proc/loadavg');
1105:
1106: $loadavg=<$loadfile>;
1107: $loadavg =~ s/\s.*//g; # Extract the first field only.
1108:
1109: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
1110:
1.387 albertel 1111: &Reply( $replyfd, \$loadpercent, "$cmd:$tail");
1.217 foxr 1112:
1113: return 1;
1114: }
1.263 albertel 1115: ®ister_handler("load", \&load_handler, 0, 1, 0);
1.217 foxr 1116:
1117: #
1118: # Process the userload request. This sub returns to the client the current
1119: # user load average. It can be invoked either by clients or managers.
1120: #
1121: # Parameters:
1122: # $cmd - the actual keyword that invoked us.
1123: # $tail - the tail of the request that invoked us.
1124: # $replyfd- File descriptor connected to the client
1125: # Implicit Inputs:
1126: # $currenthostid - Global variable that carries the name of the host
1127: # known as.
1128: # $clientname - Global variable that carries the name of the hsot we're connected to.
1129: # Returns:
1130: # 1 - Ok to continue processing.
1131: # 0 - Program should exit
1132: # Implicit inputs:
1133: # whatever the userload() function requires.
1134: # Implicit outputs:
1135: # the reply is written to the client.
1136: #
1137: sub user_load_handler {
1138: my ($cmd, $tail, $replyfd) = @_;
1139:
1.365 albertel 1140: my $userloadpercent=&Apache::lonnet::userload();
1.387 albertel 1141: &Reply($replyfd, \$userloadpercent, "$cmd:$tail");
1.217 foxr 1142:
1143: return 1;
1144: }
1.263 albertel 1145: ®ister_handler("userload", \&user_load_handler, 0, 1, 0);
1.217 foxr 1146:
1.218 foxr 1147: # Process a request for the authorization type of a user:
1148: # (userauth).
1149: #
1150: # Parameters:
1151: # $cmd - the actual keyword that invoked us.
1152: # $tail - the tail of the request that invoked us.
1153: # $replyfd- File descriptor connected to the client
1154: # Returns:
1155: # 1 - Ok to continue processing.
1156: # 0 - Program should exit
1157: # Implicit outputs:
1158: # The user authorization type is written to the client.
1159: #
1160: sub user_authorization_type {
1161: my ($cmd, $tail, $replyfd) = @_;
1162:
1163: my $userinput = "$cmd:$tail";
1164:
1165: # Pull the domain and username out of the command tail.
1.222 foxr 1166: # and call get_auth_type to determine the authentication type.
1.218 foxr 1167:
1168: my ($udom,$uname)=split(/:/,$tail);
1.222 foxr 1169: my $result = &get_auth_type($udom, $uname);
1.218 foxr 1170: if($result eq "nouser") {
1171: &Failure( $replyfd, "unknown_user\n", $userinput);
1172: } else {
1173: #
1.222 foxr 1174: # We only want to pass the second field from get_auth_type
1.218 foxr 1175: # for ^krb.. otherwise we'll be handing out the encrypted
1176: # password for internals e.g.
1177: #
1178: my ($type,$otherinfo) = split(/:/,$result);
1179: if($type =~ /^krb/) {
1180: $type = $result;
1.269 raeburn 1181: } else {
1182: $type .= ':';
1183: }
1.387 albertel 1184: &Reply( $replyfd, \$type, $userinput);
1.218 foxr 1185: }
1186:
1187: return 1;
1188: }
1189: ®ister_handler("currentauth", \&user_authorization_type, 1, 1, 0);
1190:
1191: # Process a request by a manager to push a hosts or domain table
1192: # to us. We pick apart the command and pass it on to the subs
1193: # that already exist to do this.
1194: #
1195: # Parameters:
1196: # $cmd - the actual keyword that invoked us.
1197: # $tail - the tail of the request that invoked us.
1198: # $client - File descriptor connected to the client
1199: # Returns:
1200: # 1 - Ok to continue processing.
1201: # 0 - Program should exit
1202: # Implicit Output:
1203: # a reply is written to the client.
1204: sub push_file_handler {
1205: my ($cmd, $tail, $client) = @_;
1206:
1207: my $userinput = "$cmd:$tail";
1208:
1209: # At this time we only know that the IP of our partner is a valid manager
1210: # the code below is a hook to do further authentication (e.g. to resolve
1211: # spoofing).
1212:
1213: my $cert = &GetCertificate($userinput);
1214: if(&ValidManager($cert)) {
1215:
1216: # Now presumably we have the bona fides of both the peer host and the
1217: # process making the request.
1218:
1219: my $reply = &PushFile($userinput);
1.387 albertel 1220: &Reply($client, \$reply, $userinput);
1.218 foxr 1221:
1222: } else {
1223: &Failure( $client, "refused\n", $userinput);
1224: }
1.219 foxr 1225: return 1;
1.218 foxr 1226: }
1227: ®ister_handler("pushfile", \&push_file_handler, 1, 0, 1);
1228:
1.399 raeburn 1229: # The du_handler routine should be considered obsolete and is retained
1230: # for communication with legacy servers. Please see the du2_handler.
1.243 banghart 1231: #
1.399 raeburn 1232: # du - list the disk usage of a directory recursively.
1.243 banghart 1233: #
1234: # note: stolen code from the ls file handler
1235: # under construction by Rick Banghart
1236: # .
1237: # Parameters:
1238: # $cmd - The command that dispatched us (du).
1239: # $ududir - The directory path to list... I'm not sure what this
1240: # is relative as things like ls:. return e.g.
1241: # no_such_dir.
1242: # $client - Socket open on the client.
1243: # Returns:
1244: # 1 - indicating that the daemon should not disconnect.
1245: # Side Effects:
1246: # The reply is written to $client.
1247: #
1248: sub du_handler {
1249: my ($cmd, $ududir, $client) = @_;
1.339 albertel 1250: ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
1.251 foxr 1251: my $userinput = "$cmd:$ududir";
1252:
1.245 albertel 1253: if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
1254: &Failure($client,"refused\n","$cmd:$ududir");
1255: return 1;
1256: }
1.249 foxr 1257: # Since $ududir could have some nasties in it,
1258: # we will require that ududir is a valid
1259: # directory. Just in case someone tries to
1260: # slip us a line like .;(cd /home/httpd rm -rf*)
1261: # etc.
1262: #
1263: if (-d $ududir) {
1.292 albertel 1264: my $total_size=0;
1265: my $code=sub {
1266: if ($_=~/\.\d+\./) { return;}
1267: if ($_=~/\.meta$/) { return;}
1.362 albertel 1268: if (-d $_) { return;}
1.292 albertel 1269: $total_size+=(stat($_))[7];
1270: };
1.295 raeburn 1271: chdir($ududir);
1.292 albertel 1272: find($code,$ududir);
1273: $total_size=int($total_size/1024);
1.387 albertel 1274: &Reply($client,\$total_size,"$cmd:$ududir");
1.249 foxr 1275: } else {
1.251 foxr 1276: &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");
1.249 foxr 1277: }
1.243 banghart 1278: return 1;
1279: }
1280: ®ister_handler("du", \&du_handler, 0, 1, 0);
1.218 foxr 1281:
1.399 raeburn 1282: # Please also see the du_handler, which is obsoleted by du2.
1283: # du2_handler differs from du_handler in that required path to directory
1284: # provided by &propath() is prepended in the handler instead of on the
1285: # client side.
1.239 foxr 1286: #
1.399 raeburn 1287: # du2 - list the disk usage of a directory recursively.
1288: #
1289: # Parameters:
1290: # $cmd - The command that dispatched us (du).
1291: # $tail - The tail of the request that invoked us.
1292: # $tail is a : separated list of the following:
1293: # - $ududir - directory path to list (before prepending)
1294: # - $getpropath = 1 if &propath() should prepend
1295: # - $uname - username to use for &propath or user dir
1296: # - $udom - domain to use for &propath or user dir
1297: # All are escaped.
1298: # $client - Socket open on the client.
1299: # Returns:
1300: # 1 - indicating that the daemon should not disconnect.
1301: # Side Effects:
1302: # The reply is written to $client.
1303: #
1304:
1305: sub du2_handler {
1306: my ($cmd, $tail, $client) = @_;
1307: my ($ududir,$getpropath,$uname,$udom) = map { &unescape($_) } (split(/:/, $tail));
1308: my $userinput = "$cmd:$tail";
1309: if (($ududir=~/\.\./) || (($ududir!~m|^/home/httpd/|) && (!$getpropath))) {
1310: &Failure($client,"refused\n","$cmd:$tail");
1311: return 1;
1312: }
1313: if ($getpropath) {
1314: if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
1315: $ududir = &propath($udom,$uname).'/'.$ududir;
1316: } else {
1317: &Failure($client,"refused\n","$cmd:$tail");
1318: return 1;
1319: }
1320: }
1321: # Since $ududir could have some nasties in it,
1322: # we will require that ududir is a valid
1323: # directory. Just in case someone tries to
1324: # slip us a line like .;(cd /home/httpd rm -rf*)
1325: # etc.
1326: #
1327: if (-d $ududir) {
1328: my $total_size=0;
1329: my $code=sub {
1330: if ($_=~/\.\d+\./) { return;}
1331: if ($_=~/\.meta$/) { return;}
1332: if (-d $_) { return;}
1333: $total_size+=(stat($_))[7];
1334: };
1335: chdir($ududir);
1336: find($code,$ududir);
1337: $total_size=int($total_size/1024);
1338: &Reply($client,\$total_size,"$cmd:$ududir");
1339: } else {
1340: &Failure($client, "bad_directory:$ududir\n","$cmd:$tail");
1341: }
1342: return 1;
1343: }
1344: ®ister_handler("du2", \&du2_handler, 0, 1, 0);
1345:
1346: #
1347: # The ls_handler routine should be considered obsolete and is retained
1348: # for communication with legacy servers. Please see the ls3_handler.
1.280 matthew 1349: #
1.239 foxr 1350: # ls - list the contents of a directory. For each file in the
1351: # selected directory the filename followed by the full output of
1352: # the stat function is returned. The returned info for each
1353: # file are separated by ':'. The stat fields are separated by &'s.
1354: # Parameters:
1355: # $cmd - The command that dispatched us (ls).
1356: # $ulsdir - The directory path to list... I'm not sure what this
1357: # is relative as things like ls:. return e.g.
1358: # no_such_dir.
1359: # $client - Socket open on the client.
1360: # Returns:
1361: # 1 - indicating that the daemon should not disconnect.
1362: # Side Effects:
1363: # The reply is written to $client.
1364: #
1365: sub ls_handler {
1.280 matthew 1366: # obsoleted by ls2_handler
1.239 foxr 1367: my ($cmd, $ulsdir, $client) = @_;
1368:
1369: my $userinput = "$cmd:$ulsdir";
1370:
1371: my $obs;
1372: my $rights;
1373: my $ulsout='';
1374: my $ulsfn;
1375: if (-e $ulsdir) {
1376: if(-d $ulsdir) {
1377: if (opendir(LSDIR,$ulsdir)) {
1378: while ($ulsfn=readdir(LSDIR)) {
1.291 albertel 1379: undef($obs);
1380: undef($rights);
1.239 foxr 1381: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1382: #We do some obsolete checking here
1383: if(-e $ulsdir.'/'.$ulsfn.".meta") {
1384: open(FILE, $ulsdir.'/'.$ulsfn.".meta");
1385: my @obsolete=<FILE>;
1386: foreach my $obsolete (@obsolete) {
1.301 www 1387: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
1.239 foxr 1388: if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
1389: }
1390: }
1391: $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
1392: if($obs eq '1') { $ulsout.="&1"; }
1393: else { $ulsout.="&0"; }
1394: if($rights eq '1') { $ulsout.="&1:"; }
1395: else { $ulsout.="&0:"; }
1396: }
1397: closedir(LSDIR);
1398: }
1399: } else {
1400: my @ulsstats=stat($ulsdir);
1401: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1402: }
1403: } else {
1404: $ulsout='no_such_dir';
1405: }
1406: if ($ulsout eq '') { $ulsout='empty'; }
1.387 albertel 1407: &Reply($client, \$ulsout, $userinput); # This supports debug logging.
1.239 foxr 1408:
1409: return 1;
1410:
1411: }
1412: ®ister_handler("ls", \&ls_handler, 0, 1, 0);
1413:
1.399 raeburn 1414: # The ls2_handler routine should be considered obsolete and is retained
1415: # for communication with legacy servers. Please see the ls3_handler.
1416: # Please also see the ls_handler, which was itself obsoleted by ls2.
1.280 matthew 1417: # ls2_handler differs from ls_handler in that it escapes its return
1418: # values before concatenating them together with ':'s.
1419: #
1420: # ls2 - list the contents of a directory. For each file in the
1421: # selected directory the filename followed by the full output of
1422: # the stat function is returned. The returned info for each
1423: # file are separated by ':'. The stat fields are separated by &'s.
1424: # Parameters:
1425: # $cmd - The command that dispatched us (ls).
1426: # $ulsdir - The directory path to list... I'm not sure what this
1427: # is relative as things like ls:. return e.g.
1428: # no_such_dir.
1429: # $client - Socket open on the client.
1430: # Returns:
1431: # 1 - indicating that the daemon should not disconnect.
1432: # Side Effects:
1433: # The reply is written to $client.
1434: #
1435: sub ls2_handler {
1436: my ($cmd, $ulsdir, $client) = @_;
1437:
1438: my $userinput = "$cmd:$ulsdir";
1439:
1440: my $obs;
1441: my $rights;
1442: my $ulsout='';
1443: my $ulsfn;
1444: if (-e $ulsdir) {
1445: if(-d $ulsdir) {
1446: if (opendir(LSDIR,$ulsdir)) {
1447: while ($ulsfn=readdir(LSDIR)) {
1.291 albertel 1448: undef($obs);
1449: undef($rights);
1.280 matthew 1450: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1451: #We do some obsolete checking here
1452: if(-e $ulsdir.'/'.$ulsfn.".meta") {
1453: open(FILE, $ulsdir.'/'.$ulsfn.".meta");
1454: my @obsolete=<FILE>;
1455: foreach my $obsolete (@obsolete) {
1.301 www 1456: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
1.280 matthew 1457: if($obsolete =~ m|(<copyright>)(default)|) {
1458: $rights = 1;
1459: }
1460: }
1461: }
1462: my $tmp = $ulsfn.'&'.join('&',@ulsstats);
1463: if ($obs eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
1464: if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
1465: $ulsout.= &escape($tmp).':';
1466: }
1467: closedir(LSDIR);
1468: }
1469: } else {
1470: my @ulsstats=stat($ulsdir);
1471: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1472: }
1473: } else {
1474: $ulsout='no_such_dir';
1475: }
1476: if ($ulsout eq '') { $ulsout='empty'; }
1.387 albertel 1477: &Reply($client, \$ulsout, $userinput); # This supports debug logging.
1.280 matthew 1478: return 1;
1479: }
1480: ®ister_handler("ls2", \&ls2_handler, 0, 1, 0);
1.399 raeburn 1481: #
1482: # ls3 - list the contents of a directory. For each file in the
1483: # selected directory the filename followed by the full output of
1484: # the stat function is returned. The returned info for each
1485: # file are separated by ':'. The stat fields are separated by &'s.
1486: # Parameters:
1487: # $cmd - The command that dispatched us (ls).
1488: # $tail - The tail of the request that invoked us.
1489: # $tail is a : separated list of the following:
1490: # - $ulsdir - directory path to list (before prepending)
1491: # - $getpropath = 1 if &propath() should prepend
1492: # - $getuserdir = 1 if path to user dir in lonUsers should
1493: # prepend
1494: # - $alternate_root - path to prepend
1495: # - $uname - username to use for &propath or user dir
1496: # - $udom - domain to use for &propath or user dir
1497: # All of these except $getpropath and &getuserdir are escaped.
1498: # no_such_dir.
1499: # $client - Socket open on the client.
1500: # Returns:
1501: # 1 - indicating that the daemon should not disconnect.
1502: # Side Effects:
1503: # The reply is written to $client.
1504: #
1505:
1506: sub ls3_handler {
1507: my ($cmd, $tail, $client) = @_;
1508: my $userinput = "$cmd:$tail";
1509: my ($ulsdir,$getpropath,$getuserdir,$alternate_root,$uname,$udom) =
1510: split(/:/,$tail);
1511: if (defined($ulsdir)) {
1512: $ulsdir = &unescape($ulsdir);
1513: }
1514: if (defined($alternate_root)) {
1515: $alternate_root = &unescape($alternate_root);
1516: }
1517: if (defined($uname)) {
1518: $uname = &unescape($uname);
1519: }
1520: if (defined($udom)) {
1521: $udom = &unescape($udom);
1522: }
1523:
1524: my $dir_root = $perlvar{'lonDocRoot'};
1525: if ($getpropath) {
1526: if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
1527: $dir_root = &propath($udom,$uname);
1528: $dir_root =~ s/\/$//;
1529: } else {
1530: &Failure($client,"refused\n","$cmd:$tail");
1531: return 1;
1532: }
1533: } elsif ($getuserdir) {
1534: if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
1535: my $subdir=$uname.'__';
1536: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
1537: $dir_root = $Apache::lonnet::perlvar{'lonUsersDir'}
1538: ."/$udom/$subdir/$uname";
1539: } else {
1540: &Failure($client,"refused\n","$cmd:$tail");
1541: return 1;
1542: }
1.400 raeburn 1543: } elsif ($alternate_root ne '') {
1.399 raeburn 1544: $dir_root = $alternate_root;
1545: }
1.408 raeburn 1546: if (($dir_root ne '') && ($dir_root ne '/')) {
1.400 raeburn 1547: if ($ulsdir =~ /^\//) {
1548: $ulsdir = $dir_root.$ulsdir;
1549: } else {
1550: $ulsdir = $dir_root.'/'.$ulsdir;
1551: }
1.399 raeburn 1552: }
1553: my $obs;
1554: my $rights;
1555: my $ulsout='';
1556: my $ulsfn;
1557: if (-e $ulsdir) {
1558: if(-d $ulsdir) {
1559: if (opendir(LSDIR,$ulsdir)) {
1560: while ($ulsfn=readdir(LSDIR)) {
1561: undef($obs);
1562: undef($rights);
1563: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1564: #We do some obsolete checking here
1565: if(-e $ulsdir.'/'.$ulsfn.".meta") {
1566: open(FILE, $ulsdir.'/'.$ulsfn.".meta");
1567: my @obsolete=<FILE>;
1568: foreach my $obsolete (@obsolete) {
1569: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
1570: if($obsolete =~ m|(<copyright>)(default)|) {
1571: $rights = 1;
1572: }
1573: }
1574: }
1575: my $tmp = $ulsfn.'&'.join('&',@ulsstats);
1576: if ($obs eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
1577: if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
1578: $ulsout.= &escape($tmp).':';
1579: }
1580: closedir(LSDIR);
1581: }
1582: } else {
1583: my @ulsstats=stat($ulsdir);
1584: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1585: }
1586: } else {
1587: $ulsout='no_such_dir';
1.400 raeburn 1588: }
1589: if ($ulsout eq '') { $ulsout='empty'; }
1590: &Reply($client, \$ulsout, $userinput); # This supports debug logging.
1591: return 1;
1.399 raeburn 1592: }
1593: ®ister_handler("ls3", \&ls3_handler, 0, 1, 0);
1.280 matthew 1594:
1.410 raeburn 1595: sub server_timezone_handler {
1596: my ($cmd,$tail,$client) = @_;
1597: my $userinput = "$cmd:$tail";
1598: my $timezone;
1599: my $clockfile = '/etc/sysconfig/clock'; # Fedora/CentOS/SuSE
1600: my $tzfile = '/etc/timezone'; # Debian/Ubuntu
1601: if (-e $clockfile) {
1602: if (open(my $fh,"<$clockfile")) {
1603: while (<$fh>) {
1604: next if (/^[\#\s]/);
1605: if (/^(?:TIME)?ZONE\s*=\s*['"]?\s*([\w\/]+)/) {
1606: $timezone = $1;
1607: last;
1608: }
1609: }
1610: close($fh);
1611: }
1612: } elsif (-e $tzfile) {
1613: if (open(my $fh,"<$tzfile")) {
1614: $timezone = <$fh>;
1615: close($fh);
1616: chomp($timezone);
1617: if ($timezone =~ m{^Etc/(\w+)$}) {
1618: $timezone = $1;
1619: }
1620: }
1621: }
1622: &Reply($client,\$timezone,$userinput); # This supports debug logging.
1623: return 1;
1624: }
1625: ®ister_handler("servertimezone", \&server_timezone_handler, 0, 1, 0);
1626:
1.218 foxr 1627: # Process a reinit request. Reinit requests that either
1628: # lonc or lond be reinitialized so that an updated
1629: # host.tab or domain.tab can be processed.
1630: #
1631: # Parameters:
1632: # $cmd - the actual keyword that invoked us.
1633: # $tail - the tail of the request that invoked us.
1634: # $client - File descriptor connected to the client
1635: # Returns:
1636: # 1 - Ok to continue processing.
1637: # 0 - Program should exit
1638: # Implicit output:
1639: # a reply is sent to the client.
1640: #
1641: sub reinit_process_handler {
1642: my ($cmd, $tail, $client) = @_;
1643:
1644: my $userinput = "$cmd:$tail";
1645:
1646: my $cert = &GetCertificate($userinput);
1647: if(&ValidManager($cert)) {
1648: chomp($userinput);
1649: my $reply = &ReinitProcess($userinput);
1.387 albertel 1650: &Reply( $client, \$reply, $userinput);
1.218 foxr 1651: } else {
1652: &Failure( $client, "refused\n", $userinput);
1653: }
1654: return 1;
1655: }
1656: ®ister_handler("reinit", \&reinit_process_handler, 1, 0, 1);
1657:
1658: # Process the editing script for a table edit operation.
1659: # the editing operation must be encrypted and requested by
1660: # a manager host.
1661: #
1662: # Parameters:
1663: # $cmd - the actual keyword that invoked us.
1664: # $tail - the tail of the request that invoked us.
1665: # $client - File descriptor connected to the client
1666: # Returns:
1667: # 1 - Ok to continue processing.
1668: # 0 - Program should exit
1669: # Implicit output:
1670: # a reply is sent to the client.
1671: #
1672: sub edit_table_handler {
1673: my ($command, $tail, $client) = @_;
1674:
1675: my $userinput = "$command:$tail";
1676:
1677: my $cert = &GetCertificate($userinput);
1678: if(&ValidManager($cert)) {
1679: my($filetype, $script) = split(/:/, $tail);
1680: if (($filetype eq "hosts") ||
1681: ($filetype eq "domain")) {
1682: if($script ne "") {
1683: &Reply($client, # BUGBUG - EditFile
1684: &EditFile($userinput), # could fail.
1685: $userinput);
1686: } else {
1687: &Failure($client,"refused\n",$userinput);
1688: }
1689: } else {
1690: &Failure($client,"refused\n",$userinput);
1691: }
1692: } else {
1693: &Failure($client,"refused\n",$userinput);
1694: }
1695: return 1;
1696: }
1.263 albertel 1697: ®ister_handler("edit", \&edit_table_handler, 1, 0, 1);
1.218 foxr 1698:
1.220 foxr 1699: #
1700: # Authenticate a user against the LonCAPA authentication
1701: # database. Note that there are several authentication
1702: # possibilities:
1703: # - unix - The user can be authenticated against the unix
1704: # password file.
1705: # - internal - The user can be authenticated against a purely
1706: # internal per user password file.
1707: # - kerberos - The user can be authenticated against either a kerb4 or kerb5
1708: # ticket granting authority.
1709: # - user - The person tailoring LonCAPA can supply a user authentication
1710: # mechanism that is per system.
1711: #
1712: # Parameters:
1713: # $cmd - The command that got us here.
1714: # $tail - Tail of the command (remaining parameters).
1715: # $client - File descriptor connected to client.
1716: # Returns
1717: # 0 - Requested to exit, caller should shut down.
1718: # 1 - Continue processing.
1719: # Implicit inputs:
1720: # The authentication systems describe above have their own forms of implicit
1721: # input into the authentication process that are described above.
1722: #
1723: sub authenticate_handler {
1724: my ($cmd, $tail, $client) = @_;
1725:
1726:
1727: # Regenerate the full input line
1728:
1729: my $userinput = $cmd.":".$tail;
1730:
1731: # udom - User's domain.
1732: # uname - Username.
1733: # upass - User's password.
1.396 raeburn 1734: # checkdefauth - Pass to validate_user() to try authentication
1735: # with default auth type(s) if no user account.
1.220 foxr 1736:
1.396 raeburn 1737: my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);
1.399 raeburn 1738: &Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth");
1.220 foxr 1739: chomp($upass);
1740: $upass=&unescape($upass);
1741:
1.396 raeburn 1742: my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
1.220 foxr 1743: if($pwdcorrect) {
1744: &Reply( $client, "authorized\n", $userinput);
1745: #
1746: # Bad credentials: Failed to authorize
1747: #
1748: } else {
1749: &Failure( $client, "non_authorized\n", $userinput);
1750: }
1751:
1752: return 1;
1753: }
1.263 albertel 1754: ®ister_handler("auth", \&authenticate_handler, 1, 1, 0);
1.214 foxr 1755:
1.222 foxr 1756: #
1757: # Change a user's password. Note that this function is complicated by
1758: # the fact that a user may be authenticated in more than one way:
1759: # At present, we are not able to change the password for all types of
1760: # authentication methods. Only for:
1761: # unix - unix password or shadow passoword style authentication.
1762: # local - Locally written authentication mechanism.
1763: # For now, kerb4 and kerb5 password changes are not supported and result
1764: # in an error.
1765: # FUTURE WORK:
1766: # Support kerberos passwd changes?
1767: # Parameters:
1768: # $cmd - The command that got us here.
1769: # $tail - Tail of the command (remaining parameters).
1770: # $client - File descriptor connected to client.
1771: # Returns
1772: # 0 - Requested to exit, caller should shut down.
1773: # 1 - Continue processing.
1774: # Implicit inputs:
1775: # The authentication systems describe above have their own forms of implicit
1776: # input into the authentication process that are described above.
1777: sub change_password_handler {
1778: my ($cmd, $tail, $client) = @_;
1779:
1780: my $userinput = $cmd.":".$tail; # Reconstruct client's string.
1781:
1782: #
1783: # udom - user's domain.
1784: # uname - Username.
1785: # upass - Current password.
1786: # npass - New password.
1.346 raeburn 1787: # context - Context in which this was called
1788: # (preferences or reset_by_email).
1.222 foxr 1789:
1.346 raeburn 1790: my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail);
1.222 foxr 1791:
1792: $upass=&unescape($upass);
1793: $npass=&unescape($npass);
1794: &Debug("Trying to change password for $uname");
1795:
1796: # First require that the user can be authenticated with their
1.346 raeburn 1797: # old password unless context was 'reset_by_email':
1798:
1799: my $validated;
1800: if ($context eq 'reset_by_email') {
1801: $validated = 1;
1802: } else {
1803: $validated = &validate_user($udom, $uname, $upass);
1804: }
1.222 foxr 1805: if($validated) {
1806: my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd.
1807:
1808: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
1809: if ($howpwd eq 'internal') {
1810: &Debug("internal auth");
1811: my $salt=time;
1812: $salt=substr($salt,6,2);
1813: my $ncpass=crypt($npass,$salt);
1814: if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
1815: &logthis("Result of password change for "
1816: ."$uname: pwchange_success");
1817: &Reply($client, "ok\n", $userinput);
1818: } else {
1819: &logthis("Unable to open $uname passwd "
1820: ."to change password");
1821: &Failure( $client, "non_authorized\n",$userinput);
1822: }
1.346 raeburn 1823: } elsif ($howpwd eq 'unix' && $context ne 'reset_by_email') {
1.287 foxr 1824: my $result = &change_unix_password($uname, $npass);
1.222 foxr 1825: &logthis("Result of password change for $uname: ".
1.287 foxr 1826: $result);
1.387 albertel 1827: &Reply($client, \$result, $userinput);
1.222 foxr 1828: } else {
1829: # this just means that the current password mode is not
1830: # one we know how to change (e.g the kerberos auth modes or
1831: # locally written auth handler).
1832: #
1833: &Failure( $client, "auth_mode_error\n", $userinput);
1834: }
1835:
1.224 foxr 1836: } else {
1.222 foxr 1837: &Failure( $client, "non_authorized\n", $userinput);
1838: }
1839:
1840: return 1;
1841: }
1.263 albertel 1842: ®ister_handler("passwd", \&change_password_handler, 1, 1, 0);
1.222 foxr 1843:
1.225 foxr 1844: #
1845: # Create a new user. User in this case means a lon-capa user.
1846: # The user must either already exist in some authentication realm
1847: # like kerberos or the /etc/passwd. If not, a user completely local to
1848: # this loncapa system is created.
1849: #
1850: # Parameters:
1851: # $cmd - The command that got us here.
1852: # $tail - Tail of the command (remaining parameters).
1853: # $client - File descriptor connected to client.
1854: # Returns
1855: # 0 - Requested to exit, caller should shut down.
1856: # 1 - Continue processing.
1857: # Implicit inputs:
1858: # The authentication systems describe above have their own forms of implicit
1859: # input into the authentication process that are described above.
1860: sub add_user_handler {
1861:
1862: my ($cmd, $tail, $client) = @_;
1863:
1864:
1865: my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
1866: my $userinput = $cmd.":".$tail; # Reconstruct the full request line.
1867:
1868: &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);
1869:
1870:
1871: if($udom eq $currentdomainid) { # Reject new users for other domains...
1872:
1873: my $oldumask=umask(0077);
1874: chomp($npass);
1875: $npass=&unescape($npass);
1876: my $passfilename = &password_path($udom, $uname);
1877: &Debug("Password file created will be:".$passfilename);
1878: if (-e $passfilename) {
1879: &Failure( $client, "already_exists\n", $userinput);
1880: } else {
1881: my $fperror='';
1.264 albertel 1882: if (!&mkpath($passfilename)) {
1883: $fperror="error: ".($!+0)." mkdir failed while attempting "
1884: ."makeuser";
1.225 foxr 1885: }
1886: unless ($fperror) {
1887: my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
1.390 raeburn 1888: &Reply($client,\$result, $userinput); #BUGBUG - could be fail
1.225 foxr 1889: } else {
1.387 albertel 1890: &Failure($client, \$fperror, $userinput);
1.225 foxr 1891: }
1892: }
1893: umask($oldumask);
1894: } else {
1895: &Failure($client, "not_right_domain\n",
1896: $userinput); # Even if we are multihomed.
1897:
1898: }
1899: return 1;
1900:
1901: }
1902: ®ister_handler("makeuser", \&add_user_handler, 1, 1, 0);
1903:
1904: #
1905: # Change the authentication method of a user. Note that this may
1906: # also implicitly change the user's password if, for example, the user is
1907: # joining an existing authentication realm. Known authentication realms at
1908: # this time are:
1909: # internal - Purely internal password file (only loncapa knows this user)
1910: # local - Institutionally written authentication module.
1911: # unix - Unix user (/etc/passwd with or without /etc/shadow).
1912: # kerb4 - kerberos version 4
1913: # kerb5 - kerberos version 5
1914: #
1915: # Parameters:
1916: # $cmd - The command that got us here.
1917: # $tail - Tail of the command (remaining parameters).
1918: # $client - File descriptor connected to client.
1919: # Returns
1920: # 0 - Requested to exit, caller should shut down.
1921: # 1 - Continue processing.
1922: # Implicit inputs:
1923: # The authentication systems describe above have their own forms of implicit
1924: # input into the authentication process that are described above.
1.287 foxr 1925: # NOTE:
1926: # This is also used to change the authentication credential values (e.g. passwd).
1927: #
1.225 foxr 1928: #
1929: sub change_authentication_handler {
1930:
1931: my ($cmd, $tail, $client) = @_;
1932:
1933: my $userinput = "$cmd:$tail"; # Reconstruct user input.
1934:
1935: my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
1936: &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode);
1937: if ($udom ne $currentdomainid) {
1938: &Failure( $client, "not_right_domain\n", $client);
1939: } else {
1940:
1941: chomp($npass);
1942:
1943: $npass=&unescape($npass);
1.261 foxr 1944: my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.
1.225 foxr 1945: my $passfilename = &password_path($udom, $uname);
1946: if ($passfilename) { # Not allowed to create a new user!!
1.287 foxr 1947: # If just changing the unix passwd. need to arrange to run
1948: # passwd since otherwise make_passwd_file will run
1949: # lcuseradd which fails if an account already exists
1950: # (to prevent an unscrupulous LONCAPA admin from stealing
1951: # an existing account by overwriting it as a LonCAPA account).
1952:
1953: if(($oldauth =~/^unix/) && ($umode eq "unix")) {
1954: my $result = &change_unix_password($uname, $npass);
1955: &logthis("Result of password change for $uname: ".$result);
1956: if ($result eq "ok") {
1.390 raeburn 1957: &Reply($client, \$result);
1.288 albertel 1958: } else {
1.387 albertel 1959: &Failure($client, \$result);
1.287 foxr 1960: }
1.288 albertel 1961: } else {
1.287 foxr 1962: my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
1963: #
1964: # If the current auth mode is internal, and the old auth mode was
1965: # unix, or krb*, and the user is an author for this domain,
1966: # re-run manage_permissions for that role in order to be able
1967: # to take ownership of the construction space back to www:www
1968: #
1969:
1970:
1971: if( (($oldauth =~ /^unix/) && ($umode eq "internal")) ||
1972: (($oldauth =~ /^internal/) && ($umode eq "unix")) ) {
1973: if(&is_author($udom, $uname)) {
1974: &Debug(" Need to manage author permissions...");
1975: &manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
1976: }
1.261 foxr 1977: }
1.387 albertel 1978: &Reply($client, \$result, $userinput);
1.261 foxr 1979: }
1980:
1981:
1.225 foxr 1982: } else {
1.251 foxr 1983: &Failure($client, "non_authorized\n", $userinput); # Fail the user now.
1.225 foxr 1984: }
1985: }
1986: return 1;
1987: }
1988: ®ister_handler("changeuserauth", \&change_authentication_handler, 1,1, 0);
1989:
1990: #
1991: # Determines if this is the home server for a user. The home server
1992: # for a user will have his/her lon-capa passwd file. Therefore all we need
1993: # to do is determine if this file exists.
1994: #
1995: # Parameters:
1996: # $cmd - The command that got us here.
1997: # $tail - Tail of the command (remaining parameters).
1998: # $client - File descriptor connected to client.
1999: # Returns
2000: # 0 - Requested to exit, caller should shut down.
2001: # 1 - Continue processing.
2002: # Implicit inputs:
2003: # The authentication systems describe above have their own forms of implicit
2004: # input into the authentication process that are described above.
2005: #
2006: sub is_home_handler {
2007: my ($cmd, $tail, $client) = @_;
2008:
2009: my $userinput = "$cmd:$tail";
2010:
2011: my ($udom,$uname)=split(/:/,$tail);
2012: chomp($uname);
2013: my $passfile = &password_filename($udom, $uname);
2014: if($passfile) {
2015: &Reply( $client, "found\n", $userinput);
2016: } else {
2017: &Failure($client, "not_found\n", $userinput);
2018: }
2019: return 1;
2020: }
2021: ®ister_handler("home", \&is_home_handler, 0,1,0);
2022:
2023: #
2024: # Process an update request for a resource?? I think what's going on here is
2025: # that a resource has been modified that we hold a subscription to.
2026: # If the resource is not local, then we must update, or at least invalidate our
2027: # cached copy of the resource.
2028: # FUTURE WORK:
2029: # I need to look at this logic carefully. My druthers would be to follow
2030: # typical caching logic, and simple invalidate the cache, drop any subscription
2031: # an let the next fetch start the ball rolling again... however that may
2032: # actually be more difficult than it looks given the complex web of
2033: # proxy servers.
2034: # Parameters:
2035: # $cmd - The command that got us here.
2036: # $tail - Tail of the command (remaining parameters).
2037: # $client - File descriptor connected to client.
2038: # Returns
2039: # 0 - Requested to exit, caller should shut down.
2040: # 1 - Continue processing.
2041: # Implicit inputs:
2042: # The authentication systems describe above have their own forms of implicit
2043: # input into the authentication process that are described above.
2044: #
2045: sub update_resource_handler {
2046:
2047: my ($cmd, $tail, $client) = @_;
2048:
2049: my $userinput = "$cmd:$tail";
2050:
2051: my $fname= $tail; # This allows interactive testing
2052:
2053:
2054: my $ownership=ishome($fname);
2055: if ($ownership eq 'not_owner') {
2056: if (-e $fname) {
2057: my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2058: $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
2059: my $now=time;
2060: my $since=$now-$atime;
2061: if ($since>$perlvar{'lonExpire'}) {
1.365 albertel 2062: my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
1.308 albertel 2063: &devalidate_meta_cache($fname);
1.225 foxr 2064: unlink("$fname");
1.334 albertel 2065: unlink("$fname.meta");
1.225 foxr 2066: } else {
2067: my $transname="$fname.in.transfer";
1.365 albertel 2068: my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
1.225 foxr 2069: my $response;
2070: alarm(120);
2071: {
2072: my $ua=new LWP::UserAgent;
2073: my $request=new HTTP::Request('GET',"$remoteurl");
2074: $response=$ua->request($request,$transname);
2075: }
2076: alarm(0);
2077: if ($response->is_error()) {
2078: unlink($transname);
2079: my $message=$response->status_line;
2080: &logthis("LWP GET: $message for $fname ($remoteurl)");
2081: } else {
2082: if ($remoteurl!~/\.meta$/) {
2083: alarm(120);
2084: {
2085: my $ua=new LWP::UserAgent;
2086: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
2087: my $mresponse=$ua->request($mrequest,$fname.'.meta');
2088: if ($mresponse->is_error()) {
2089: unlink($fname.'.meta');
2090: }
2091: }
2092: alarm(0);
2093: }
2094: rename($transname,$fname);
1.308 albertel 2095: &devalidate_meta_cache($fname);
1.225 foxr 2096: }
2097: }
2098: &Reply( $client, "ok\n", $userinput);
2099: } else {
2100: &Failure($client, "not_found\n", $userinput);
2101: }
2102: } else {
2103: &Failure($client, "rejected\n", $userinput);
2104: }
2105: return 1;
2106: }
2107: ®ister_handler("update", \&update_resource_handler, 0 ,1, 0);
2108:
1.308 albertel 2109: sub devalidate_meta_cache {
2110: my ($url) = @_;
2111: use Cache::Memcached;
2112: my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
1.365 albertel 2113: $url = &Apache::lonnet::declutter($url);
1.308 albertel 2114: $url =~ s-\.meta$--;
2115: my $id = &escape('meta:'.$url);
2116: $memcache->delete($id);
2117: }
2118:
1.225 foxr 2119: #
1.226 foxr 2120: # Fetch a user file from a remote server to the user's home directory
2121: # userfiles subdir.
1.225 foxr 2122: # Parameters:
2123: # $cmd - The command that got us here.
2124: # $tail - Tail of the command (remaining parameters).
2125: # $client - File descriptor connected to client.
2126: # Returns
2127: # 0 - Requested to exit, caller should shut down.
2128: # 1 - Continue processing.
2129: #
2130: sub fetch_user_file_handler {
2131:
2132: my ($cmd, $tail, $client) = @_;
2133:
2134: my $userinput = "$cmd:$tail";
2135: my $fname = $tail;
1.232 foxr 2136: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
1.225 foxr 2137: my $udir=&propath($udom,$uname).'/userfiles';
2138: unless (-e $udir) {
2139: mkdir($udir,0770);
2140: }
1.232 foxr 2141: Debug("fetch user file for $fname");
1.225 foxr 2142: if (-e $udir) {
2143: $ufile=~s/^[\.\~]+//;
1.232 foxr 2144:
2145: # IF necessary, create the path right down to the file.
2146: # Note that any regular files in the way of this path are
2147: # wiped out to deal with some earlier folly of mine.
2148:
1.267 raeburn 2149: if (!&mkpath($udir.'/'.$ufile)) {
1.264 albertel 2150: &Failure($client, "unable_to_create\n", $userinput);
1.232 foxr 2151: }
2152:
1.225 foxr 2153: my $destname=$udir.'/'.$ufile;
2154: my $transname=$udir.'/'.$ufile.'.in.transit';
2155: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
2156: my $response;
1.232 foxr 2157: Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
1.225 foxr 2158: alarm(120);
2159: {
2160: my $ua=new LWP::UserAgent;
2161: my $request=new HTTP::Request('GET',"$remoteurl");
2162: $response=$ua->request($request,$transname);
2163: }
2164: alarm(0);
2165: if ($response->is_error()) {
2166: unlink($transname);
2167: my $message=$response->status_line;
2168: &logthis("LWP GET: $message for $fname ($remoteurl)");
2169: &Failure($client, "failed\n", $userinput);
2170: } else {
1.232 foxr 2171: Debug("Renaming $transname to $destname");
1.225 foxr 2172: if (!rename($transname,$destname)) {
2173: &logthis("Unable to move $transname to $destname");
2174: unlink($transname);
2175: &Failure($client, "failed\n", $userinput);
2176: } else {
2177: &Reply($client, "ok\n", $userinput);
2178: }
2179: }
2180: } else {
2181: &Failure($client, "not_home\n", $userinput);
2182: }
2183: return 1;
2184: }
2185: ®ister_handler("fetchuserfile", \&fetch_user_file_handler, 0, 1, 0);
2186:
1.226 foxr 2187: #
2188: # Remove a file from a user's home directory userfiles subdirectory.
2189: # Parameters:
2190: # cmd - the Lond request keyword that got us here.
2191: # tail - the part of the command past the keyword.
2192: # client- File descriptor connected with the client.
2193: #
2194: # Returns:
2195: # 1 - Continue processing.
2196: sub remove_user_file_handler {
2197: my ($cmd, $tail, $client) = @_;
2198:
2199: my ($fname) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
2200:
2201: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
2202: if ($ufile =~m|/\.\./|) {
2203: # any files paths with /../ in them refuse
2204: # to deal with
2205: &Failure($client, "refused\n", "$cmd:$tail");
2206: } else {
2207: my $udir = &propath($udom,$uname);
2208: if (-e $udir) {
2209: my $file=$udir.'/userfiles/'.$ufile;
2210: if (-e $file) {
1.253 foxr 2211: #
2212: # If the file is a regular file unlink is fine...
2213: # However it's possible the client wants a dir.
2214: # removed, in which case rmdir is more approprate:
2215: #
1.240 banghart 2216: if (-f $file){
1.241 albertel 2217: unlink($file);
2218: } elsif(-d $file) {
2219: rmdir($file);
1.240 banghart 2220: }
1.226 foxr 2221: if (-e $file) {
1.253 foxr 2222: # File is still there after we deleted it ?!?
2223:
1.226 foxr 2224: &Failure($client, "failed\n", "$cmd:$tail");
2225: } else {
2226: &Reply($client, "ok\n", "$cmd:$tail");
2227: }
2228: } else {
2229: &Failure($client, "not_found\n", "$cmd:$tail");
2230: }
2231: } else {
2232: &Failure($client, "not_home\n", "$cmd:$tail");
2233: }
2234: }
2235: return 1;
2236: }
2237: ®ister_handler("removeuserfile", \&remove_user_file_handler, 0,1,0);
2238:
1.236 albertel 2239: #
2240: # make a directory in a user's home directory userfiles subdirectory.
2241: # Parameters:
2242: # cmd - the Lond request keyword that got us here.
2243: # tail - the part of the command past the keyword.
2244: # client- File descriptor connected with the client.
2245: #
2246: # Returns:
2247: # 1 - Continue processing.
2248: sub mkdir_user_file_handler {
2249: my ($cmd, $tail, $client) = @_;
2250:
2251: my ($dir) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
2252: $dir=&unescape($dir);
2253: my ($udom,$uname,$ufile) = ($dir =~ m|^([^/]+)/([^/]+)/(.+)$|);
2254: if ($ufile =~m|/\.\./|) {
2255: # any files paths with /../ in them refuse
2256: # to deal with
2257: &Failure($client, "refused\n", "$cmd:$tail");
2258: } else {
2259: my $udir = &propath($udom,$uname);
2260: if (-e $udir) {
1.264 albertel 2261: my $newdir=$udir.'/userfiles/'.$ufile.'/';
2262: if (!&mkpath($newdir)) {
2263: &Failure($client, "failed\n", "$cmd:$tail");
1.236 albertel 2264: }
1.264 albertel 2265: &Reply($client, "ok\n", "$cmd:$tail");
1.236 albertel 2266: } else {
2267: &Failure($client, "not_home\n", "$cmd:$tail");
2268: }
2269: }
2270: return 1;
2271: }
2272: ®ister_handler("mkdiruserfile", \&mkdir_user_file_handler, 0,1,0);
2273:
1.237 albertel 2274: #
2275: # rename a file in a user's home directory userfiles subdirectory.
2276: # Parameters:
2277: # cmd - the Lond request keyword that got us here.
2278: # tail - the part of the command past the keyword.
2279: # client- File descriptor connected with the client.
2280: #
2281: # Returns:
2282: # 1 - Continue processing.
2283: sub rename_user_file_handler {
2284: my ($cmd, $tail, $client) = @_;
2285:
2286: my ($udom,$uname,$old,$new) = split(/:/, $tail);
2287: $old=&unescape($old);
2288: $new=&unescape($new);
2289: if ($new =~m|/\.\./| || $old =~m|/\.\./|) {
2290: # any files paths with /../ in them refuse to deal with
2291: &Failure($client, "refused\n", "$cmd:$tail");
2292: } else {
2293: my $udir = &propath($udom,$uname);
2294: if (-e $udir) {
2295: my $oldfile=$udir.'/userfiles/'.$old;
2296: my $newfile=$udir.'/userfiles/'.$new;
2297: if (-e $newfile) {
2298: &Failure($client, "exists\n", "$cmd:$tail");
2299: } elsif (! -e $oldfile) {
2300: &Failure($client, "not_found\n", "$cmd:$tail");
2301: } else {
2302: if (!rename($oldfile,$newfile)) {
2303: &Failure($client, "failed\n", "$cmd:$tail");
2304: } else {
2305: &Reply($client, "ok\n", "$cmd:$tail");
2306: }
2307: }
2308: } else {
2309: &Failure($client, "not_home\n", "$cmd:$tail");
2310: }
2311: }
2312: return 1;
2313: }
2314: ®ister_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
2315:
1.227 foxr 2316: #
1.382 albertel 2317: # Checks if the specified user has an active session on the server
2318: # return ok if so, not_found if not
2319: #
2320: # Parameters:
2321: # cmd - The request keyword that dispatched to tus.
2322: # tail - The tail of the request (colon separated parameters).
2323: # client - Filehandle open on the client.
2324: # Return:
2325: # 1.
2326: sub user_has_session_handler {
2327: my ($cmd, $tail, $client) = @_;
2328:
2329: my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
2330:
2331: &logthis("Looking for $udom $uname");
2332: opendir(DIR,$perlvar{'lonIDsDir'});
2333: my $filename;
2334: while ($filename=readdir(DIR)) {
2335: last if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/);
2336: }
2337: if ($filename) {
2338: &Reply($client, "ok\n", "$cmd:$tail");
2339: } else {
2340: &Failure($client, "not_found\n", "$cmd:$tail");
2341: }
2342: return 1;
2343:
2344: }
2345: ®ister_handler("userhassession", \&user_has_session_handler, 0,1,0);
2346:
2347: #
1.263 albertel 2348: # Authenticate access to a user file by checking that the token the user's
2349: # passed also exists in their session file
1.227 foxr 2350: #
2351: # Parameters:
2352: # cmd - The request keyword that dispatched to tus.
2353: # tail - The tail of the request (colon separated parameters).
2354: # client - Filehandle open on the client.
2355: # Return:
2356: # 1.
2357: sub token_auth_user_file_handler {
2358: my ($cmd, $tail, $client) = @_;
2359:
2360: my ($fname, $session) = split(/:/, $tail);
2361:
2362: chomp($session);
1.393 raeburn 2363: my $reply="non_auth";
1.343 albertel 2364: my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
2365: if (open(ENVIN,"$file")) {
1.332 albertel 2366: flock(ENVIN,LOCK_SH);
1.343 albertel 2367: tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
2368: if (exists($disk_env{"userfile.$fname"})) {
1.393 raeburn 2369: $reply="ok";
1.343 albertel 2370: } else {
2371: foreach my $envname (keys(%disk_env)) {
2372: if ($envname=~ m|^userfile\.\Q$fname\E|) {
1.393 raeburn 2373: $reply="ok";
1.343 albertel 2374: last;
2375: }
2376: }
1.227 foxr 2377: }
1.343 albertel 2378: untie(%disk_env);
1.227 foxr 2379: close(ENVIN);
1.387 albertel 2380: &Reply($client, \$reply, "$cmd:$tail");
1.227 foxr 2381: } else {
2382: &Failure($client, "invalid_token\n", "$cmd:$tail");
2383: }
2384: return 1;
2385:
2386: }
2387: ®ister_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
1.229 foxr 2388:
2389: #
2390: # Unsubscribe from a resource.
2391: #
2392: # Parameters:
2393: # $cmd - The command that got us here.
2394: # $tail - Tail of the command (remaining parameters).
2395: # $client - File descriptor connected to client.
2396: # Returns
2397: # 0 - Requested to exit, caller should shut down.
2398: # 1 - Continue processing.
2399: #
2400: sub unsubscribe_handler {
2401: my ($cmd, $tail, $client) = @_;
2402:
2403: my $userinput= "$cmd:$tail";
2404:
2405: my ($fname) = split(/:/,$tail); # Split in case there's extrs.
2406:
2407: &Debug("Unsubscribing $fname");
2408: if (-e $fname) {
2409: &Debug("Exists");
2410: &Reply($client, &unsub($fname,$clientip), $userinput);
2411: } else {
2412: &Failure($client, "not_found\n", $userinput);
2413: }
2414: return 1;
2415: }
2416: ®ister_handler("unsub", \&unsubscribe_handler, 0, 1, 0);
1.263 albertel 2417:
1.230 foxr 2418: # Subscribe to a resource
2419: #
2420: # Parameters:
2421: # $cmd - The command that got us here.
2422: # $tail - Tail of the command (remaining parameters).
2423: # $client - File descriptor connected to client.
2424: # Returns
2425: # 0 - Requested to exit, caller should shut down.
2426: # 1 - Continue processing.
2427: #
2428: sub subscribe_handler {
2429: my ($cmd, $tail, $client)= @_;
2430:
2431: my $userinput = "$cmd:$tail";
2432:
2433: &Reply( $client, &subscribe($userinput,$clientip), $userinput);
2434:
2435: return 1;
2436: }
2437: ®ister_handler("sub", \&subscribe_handler, 0, 1, 0);
2438:
2439: #
1.379 albertel 2440: # Determine the latest version of a resource (it looks for the highest
2441: # past version and then returns that +1)
1.230 foxr 2442: #
2443: # Parameters:
2444: # $cmd - The command that got us here.
2445: # $tail - Tail of the command (remaining parameters).
1.379 albertel 2446: # (Should consist of an absolute path to a file)
1.230 foxr 2447: # $client - File descriptor connected to client.
2448: # Returns
2449: # 0 - Requested to exit, caller should shut down.
2450: # 1 - Continue processing.
2451: #
2452: sub current_version_handler {
2453: my ($cmd, $tail, $client) = @_;
2454:
2455: my $userinput= "$cmd:$tail";
2456:
2457: my $fname = $tail;
2458: &Reply( $client, ¤tversion($fname)."\n", $userinput);
2459: return 1;
2460:
2461: }
2462: ®ister_handler("currentversion", \¤t_version_handler, 0, 1, 0);
2463:
2464: # Make an entry in a user's activity log.
2465: #
2466: # Parameters:
2467: # $cmd - The command that got us here.
2468: # $tail - Tail of the command (remaining parameters).
2469: # $client - File descriptor connected to client.
2470: # Returns
2471: # 0 - Requested to exit, caller should shut down.
2472: # 1 - Continue processing.
2473: #
2474: sub activity_log_handler {
2475: my ($cmd, $tail, $client) = @_;
2476:
2477:
2478: my $userinput= "$cmd:$tail";
2479:
2480: my ($udom,$uname,$what)=split(/:/,$tail);
2481: chomp($what);
2482: my $proname=&propath($udom,$uname);
2483: my $now=time;
2484: my $hfh;
2485: if ($hfh=IO::File->new(">>$proname/activity.log")) {
2486: print $hfh "$now:$clientname:$what\n";
2487: &Reply( $client, "ok\n", $userinput);
2488: } else {
2489: &Failure($client, "error: ".($!+0)." IO::File->new Failed "
2490: ."while attempting log\n",
2491: $userinput);
2492: }
2493:
2494: return 1;
2495: }
1.263 albertel 2496: ®ister_handler("log", \&activity_log_handler, 0, 1, 0);
1.230 foxr 2497:
2498: #
2499: # Put a namespace entry in a user profile hash.
2500: # My druthers would be for this to be an encrypted interaction too.
2501: # anything that might be an inadvertent covert channel about either
2502: # user authentication or user personal information....
2503: #
2504: # Parameters:
2505: # $cmd - The command that got us here.
2506: # $tail - Tail of the command (remaining parameters).
2507: # $client - File descriptor connected to client.
2508: # Returns
2509: # 0 - Requested to exit, caller should shut down.
2510: # 1 - Continue processing.
2511: #
2512: sub put_user_profile_entry {
2513: my ($cmd, $tail, $client) = @_;
1.229 foxr 2514:
1.230 foxr 2515: my $userinput = "$cmd:$tail";
2516:
1.242 raeburn 2517: my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
1.230 foxr 2518: if ($namespace ne 'roles') {
2519: chomp($what);
2520: my $hashref = &tie_user_hash($udom, $uname, $namespace,
2521: &GDBM_WRCREAT(),"P",$what);
2522: if($hashref) {
2523: my @pairs=split(/\&/,$what);
2524: foreach my $pair (@pairs) {
2525: my ($key,$value)=split(/=/,$pair);
2526: $hashref->{$key}=$value;
2527: }
1.311 albertel 2528: if (&untie_user_hash($hashref)) {
1.230 foxr 2529: &Reply( $client, "ok\n", $userinput);
2530: } else {
2531: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
2532: "while attempting put\n",
2533: $userinput);
2534: }
2535: } else {
1.316 albertel 2536: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
1.230 foxr 2537: "while attempting put\n", $userinput);
2538: }
2539: } else {
2540: &Failure( $client, "refused\n", $userinput);
2541: }
2542:
2543: return 1;
2544: }
2545: ®ister_handler("put", \&put_user_profile_entry, 0, 1, 0);
2546:
1.283 albertel 2547: # Put a piece of new data in hash, returns error if entry already exists
2548: # Parameters:
2549: # $cmd - The command that got us here.
2550: # $tail - Tail of the command (remaining parameters).
2551: # $client - File descriptor connected to client.
2552: # Returns
2553: # 0 - Requested to exit, caller should shut down.
2554: # 1 - Continue processing.
2555: #
2556: sub newput_user_profile_entry {
2557: my ($cmd, $tail, $client) = @_;
2558:
2559: my $userinput = "$cmd:$tail";
2560:
2561: my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
2562: if ($namespace eq 'roles') {
2563: &Failure( $client, "refused\n", $userinput);
2564: return 1;
2565: }
2566:
2567: chomp($what);
2568:
2569: my $hashref = &tie_user_hash($udom, $uname, $namespace,
2570: &GDBM_WRCREAT(),"N",$what);
2571: if(!$hashref) {
1.316 albertel 2572: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
1.283 albertel 2573: "while attempting put\n", $userinput);
2574: return 1;
2575: }
2576:
2577: my @pairs=split(/\&/,$what);
2578: foreach my $pair (@pairs) {
2579: my ($key,$value)=split(/=/,$pair);
2580: if (exists($hashref->{$key})) {
2581: &Failure($client, "key_exists: ".$key."\n",$userinput);
2582: return 1;
2583: }
2584: }
2585:
2586: foreach my $pair (@pairs) {
2587: my ($key,$value)=split(/=/,$pair);
2588: $hashref->{$key}=$value;
2589: }
2590:
1.311 albertel 2591: if (&untie_user_hash($hashref)) {
1.283 albertel 2592: &Reply( $client, "ok\n", $userinput);
2593: } else {
2594: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
2595: "while attempting put\n",
2596: $userinput);
2597: }
2598: return 1;
2599: }
2600: ®ister_handler("newput", \&newput_user_profile_entry, 0, 1, 0);
2601:
1.230 foxr 2602: #
2603: # Increment a profile entry in the user history file.
2604: # The history contains keyword value pairs. In this case,
2605: # The value itself is a pair of numbers. The first, the current value
2606: # the second an increment that this function applies to the current
2607: # value.
2608: #
2609: # Parameters:
2610: # $cmd - The command that got us here.
2611: # $tail - Tail of the command (remaining parameters).
2612: # $client - File descriptor connected to client.
2613: # Returns
2614: # 0 - Requested to exit, caller should shut down.
2615: # 1 - Continue processing.
2616: #
2617: sub increment_user_value_handler {
2618: my ($cmd, $tail, $client) = @_;
2619:
2620: my $userinput = "$cmd:$tail";
2621:
2622: my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
2623: if ($namespace ne 'roles') {
2624: chomp($what);
2625: my $hashref = &tie_user_hash($udom, $uname,
2626: $namespace, &GDBM_WRCREAT(),
2627: "P",$what);
2628: if ($hashref) {
2629: my @pairs=split(/\&/,$what);
2630: foreach my $pair (@pairs) {
2631: my ($key,$value)=split(/=/,$pair);
1.284 raeburn 2632: $value = &unescape($value);
1.230 foxr 2633: # We could check that we have a number...
2634: if (! defined($value) || $value eq '') {
2635: $value = 1;
2636: }
2637: $hashref->{$key}+=$value;
1.284 raeburn 2638: if ($namespace eq 'nohist_resourcetracker') {
2639: if ($hashref->{$key} < 0) {
2640: $hashref->{$key} = 0;
2641: }
2642: }
1.230 foxr 2643: }
1.311 albertel 2644: if (&untie_user_hash($hashref)) {
1.230 foxr 2645: &Reply( $client, "ok\n", $userinput);
2646: } else {
2647: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
2648: "while attempting inc\n", $userinput);
2649: }
2650: } else {
2651: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
2652: "while attempting inc\n", $userinput);
2653: }
2654: } else {
2655: &Failure($client, "refused\n", $userinput);
2656: }
2657:
2658: return 1;
2659: }
2660: ®ister_handler("inc", \&increment_user_value_handler, 0, 1, 0);
2661:
2662: #
2663: # Put a new role for a user. Roles are LonCAPA's packaging of permissions.
2664: # Each 'role' a user has implies a set of permissions. Adding a new role
2665: # for a person grants the permissions packaged with that role
2666: # to that user when the role is selected.
2667: #
2668: # Parameters:
2669: # $cmd - The command string (rolesput).
2670: # $tail - The remainder of the request line. For rolesput this
2671: # consists of a colon separated list that contains:
2672: # The domain and user that is granting the role (logged).
2673: # The domain and user that is getting the role.
2674: # The roles being granted as a set of & separated pairs.
2675: # each pair a key value pair.
2676: # $client - File descriptor connected to the client.
2677: # Returns:
2678: # 0 - If the daemon should exit
2679: # 1 - To continue processing.
2680: #
2681: #
2682: sub roles_put_handler {
2683: my ($cmd, $tail, $client) = @_;
2684:
2685: my $userinput = "$cmd:$tail";
2686:
2687: my ( $exedom, $exeuser, $udom, $uname, $what) = split(/:/,$tail);
2688:
2689:
2690: my $namespace='roles';
2691: chomp($what);
2692: my $hashref = &tie_user_hash($udom, $uname, $namespace,
2693: &GDBM_WRCREAT(), "P",
2694: "$exedom:$exeuser:$what");
2695: #
2696: # Log the attempt to set a role. The {}'s here ensure that the file
2697: # handle is open for the minimal amount of time. Since the flush
2698: # is done on close this improves the chances the log will be an un-
2699: # corrupted ordered thing.
2700: if ($hashref) {
1.261 foxr 2701: my $pass_entry = &get_auth_type($udom, $uname);
2702: my ($auth_type,$pwd) = split(/:/, $pass_entry);
2703: $auth_type = $auth_type.":";
1.230 foxr 2704: my @pairs=split(/\&/,$what);
2705: foreach my $pair (@pairs) {
2706: my ($key,$value)=split(/=/,$pair);
2707: &manage_permissions($key, $udom, $uname,
1.260 foxr 2708: $auth_type);
1.230 foxr 2709: $hashref->{$key}=$value;
2710: }
1.311 albertel 2711: if (&untie_user_hash($hashref)) {
1.230 foxr 2712: &Reply($client, "ok\n", $userinput);
2713: } else {
2714: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
2715: "while attempting rolesput\n", $userinput);
2716: }
2717: } else {
2718: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
2719: "while attempting rolesput\n", $userinput);
2720: }
2721: return 1;
2722: }
2723: ®ister_handler("rolesput", \&roles_put_handler, 1,1,0); # Encoded client only.
2724:
2725: #
1.231 foxr 2726: # Deletes (removes) a role for a user. This is equivalent to removing
2727: # a permissions package associated with the role from the user's profile.
2728: #
2729: # Parameters:
2730: # $cmd - The command (rolesdel)
2731: # $tail - The remainder of the request line. This consists
2732: # of:
2733: # The domain and user requesting the change (logged)
2734: # The domain and user being changed.
2735: # The roles being revoked. These are shipped to us
2736: # as a bunch of & separated role name keywords.
2737: # $client - The file handle open on the client.
2738: # Returns:
2739: # 1 - Continue processing
2740: # 0 - Exit.
2741: #
2742: sub roles_delete_handler {
2743: my ($cmd, $tail, $client) = @_;
2744:
2745: my $userinput = "$cmd:$tail";
2746:
2747: my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
2748: &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
2749: "what = ".$what);
2750: my $namespace='roles';
2751: chomp($what);
2752: my $hashref = &tie_user_hash($udom, $uname, $namespace,
2753: &GDBM_WRCREAT(), "D",
2754: "$exedom:$exeuser:$what");
2755:
2756: if ($hashref) {
2757: my @rolekeys=split(/\&/,$what);
2758:
2759: foreach my $key (@rolekeys) {
2760: delete $hashref->{$key};
2761: }
1.315 albertel 2762: if (&untie_user_hash($hashref)) {
1.231 foxr 2763: &Reply($client, "ok\n", $userinput);
2764: } else {
2765: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
2766: "while attempting rolesdel\n", $userinput);
2767: }
2768: } else {
2769: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
2770: "while attempting rolesdel\n", $userinput);
2771: }
2772:
2773: return 1;
2774: }
2775: ®ister_handler("rolesdel", \&roles_delete_handler, 1,1, 0); # Encoded client only
2776:
2777: # Unencrypted get from a user's profile database. See
2778: # GetProfileEntryEncrypted for a version that does end-to-end encryption.
2779: # This function retrieves a keyed item from a specific named database in the
2780: # user's directory.
2781: #
2782: # Parameters:
2783: # $cmd - Command request keyword (get).
2784: # $tail - Tail of the command. This is a colon separated list
2785: # consisting of the domain and username that uniquely
2786: # identifies the profile,
2787: # The 'namespace' which selects the gdbm file to
2788: # do the lookup in,
2789: # & separated list of keys to lookup. Note that
2790: # the values are returned as an & separated list too.
2791: # $client - File descriptor open on the client.
2792: # Returns:
2793: # 1 - Continue processing.
2794: # 0 - Exit.
2795: #
2796: sub get_profile_entry {
2797: my ($cmd, $tail, $client) = @_;
2798:
2799: my $userinput= "$cmd:$tail";
2800:
2801: my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
2802: chomp($what);
1.255 foxr 2803:
1.390 raeburn 2804:
1.255 foxr 2805: my $replystring = read_profile($udom, $uname, $namespace, $what);
2806: my ($first) = split(/:/,$replystring);
2807: if($first ne "error") {
1.387 albertel 2808: &Reply($client, \$replystring, $userinput);
1.231 foxr 2809: } else {
1.255 foxr 2810: &Failure($client, $replystring." while attempting get\n", $userinput);
1.231 foxr 2811: }
2812: return 1;
1.255 foxr 2813:
2814:
1.231 foxr 2815: }
2816: ®ister_handler("get", \&get_profile_entry, 0,1,0);
2817:
2818: #
2819: # Process the encrypted get request. Note that the request is sent
2820: # in clear, but the reply is encrypted. This is a small covert channel:
2821: # information about the sensitive keys is given to the snooper. Just not
2822: # information about the values of the sensitive key. Hmm if I wanted to
2823: # know these I'd snoop for the egets. Get the profile item names from them
2824: # and then issue a get for them since there's no enforcement of the
2825: # requirement of an encrypted get for particular profile items. If I
2826: # were re-doing this, I'd force the request to be encrypted as well as the
2827: # reply. I'd also just enforce encrypted transactions for all gets since
2828: # that would prevent any covert channel snooping.
2829: #
2830: # Parameters:
2831: # $cmd - Command keyword of request (eget).
2832: # $tail - Tail of the command. See GetProfileEntry
# for more information about this.
2833: # $client - File open on the client.
2834: # Returns:
2835: # 1 - Continue processing
2836: # 0 - server should exit.
2837: sub get_profile_entry_encrypted {
2838: my ($cmd, $tail, $client) = @_;
2839:
2840: my $userinput = "$cmd:$tail";
2841:
1.339 albertel 2842: my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
1.231 foxr 2843: chomp($what);
1.255 foxr 2844: my $qresult = read_profile($udom, $uname, $namespace, $what);
2845: my ($first) = split(/:/, $qresult);
2846: if($first ne "error") {
2847:
2848: if ($cipher) {
2849: my $cmdlength=length($qresult);
2850: $qresult.=" ";
2851: my $encqresult='';
2852: for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
2853: $encqresult.= unpack("H16",
2854: $cipher->encrypt(substr($qresult,
2855: $encidx,
2856: 8)));
2857: }
2858: &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
2859: } else {
1.231 foxr 2860: &Failure( $client, "error:no_key\n", $userinput);
2861: }
2862: } else {
1.255 foxr 2863: &Failure($client, "$qresult while attempting eget\n", $userinput);
2864:
1.231 foxr 2865: }
2866:
2867: return 1;
2868: }
1.255 foxr 2869: ®ister_handler("eget", \&get_profile_entry_encrypted, 0, 1, 0);
1.263 albertel 2870:
1.231 foxr 2871: #
2872: # Deletes a key in a user profile database.
2873: #
2874: # Parameters:
2875: # $cmd - Command keyword (del).
2876: # $tail - Command tail. IN this case a colon
2877: # separated list containing:
2878: # The domain and user that identifies uniquely
2879: # the identity of the user.
2880: # The profile namespace (name of the profile
2881: # database file).
2882: # & separated list of keywords to delete.
2883: # $client - File open on client socket.
2884: # Returns:
2885: # 1 - Continue processing
2886: # 0 - Exit server.
2887: #
2888: #
2889: sub delete_profile_entry {
2890: my ($cmd, $tail, $client) = @_;
2891:
2892: my $userinput = "cmd:$tail";
2893:
2894: my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
2895: chomp($what);
2896: my $hashref = &tie_user_hash($udom, $uname, $namespace,
2897: &GDBM_WRCREAT(),
2898: "D",$what);
2899: if ($hashref) {
2900: my @keys=split(/\&/,$what);
2901: foreach my $key (@keys) {
2902: delete($hashref->{$key});
2903: }
1.315 albertel 2904: if (&untie_user_hash($hashref)) {
1.231 foxr 2905: &Reply($client, "ok\n", $userinput);
2906: } else {
2907: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
2908: "while attempting del\n", $userinput);
2909: }
2910: } else {
2911: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
2912: "while attempting del\n", $userinput);
2913: }
2914: return 1;
2915: }
2916: ®ister_handler("del", \&delete_profile_entry, 0, 1, 0);
1.263 albertel 2917:
1.231 foxr 2918: #
2919: # List the set of keys that are defined in a profile database file.
2920: # A successful reply from this will contain an & separated list of
2921: # the keys.
2922: # Parameters:
2923: # $cmd - Command request (keys).
2924: # $tail - Remainder of the request, a colon separated
2925: # list containing domain/user that identifies the
2926: # user being queried, and the database namespace
2927: # (database filename essentially).
2928: # $client - File open on the client.
2929: # Returns:
2930: # 1 - Continue processing.
2931: # 0 - Exit the server.
2932: #
2933: sub get_profile_keys {
2934: my ($cmd, $tail, $client) = @_;
2935:
2936: my $userinput = "$cmd:$tail";
2937:
2938: my ($udom,$uname,$namespace)=split(/:/,$tail);
2939: my $qresult='';
2940: my $hashref = &tie_user_hash($udom, $uname, $namespace,
2941: &GDBM_READER());
2942: if ($hashref) {
2943: foreach my $key (keys %$hashref) {
2944: $qresult.="$key&";
2945: }
1.315 albertel 2946: if (&untie_user_hash($hashref)) {
1.231 foxr 2947: $qresult=~s/\&$//;
1.387 albertel 2948: &Reply($client, \$qresult, $userinput);
1.231 foxr 2949: } else {
2950: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
2951: "while attempting keys\n", $userinput);
2952: }
2953: } else {
2954: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
2955: "while attempting keys\n", $userinput);
2956: }
2957:
2958: return 1;
2959: }
2960: ®ister_handler("keys", \&get_profile_keys, 0, 1, 0);
2961:
2962: #
2963: # Dump the contents of a user profile database.
2964: # Note that this constitutes a very large covert channel too since
2965: # the dump will return sensitive information that is not encrypted.
2966: # The naive security assumption is that the session negotiation ensures
2967: # our client is trusted and I don't believe that's assured at present.
2968: # Sure want badly to go to ssl or tls. Of course if my peer isn't really
2969: # a LonCAPA node they could have negotiated an encryption key too so >sigh<.
2970: #
2971: # Parameters:
2972: # $cmd - The command request keyword (currentdump).
2973: # $tail - Remainder of the request, consisting of a colon
2974: # separated list that has the domain/username and
2975: # the namespace to dump (database file).
2976: # $client - file open on the remote client.
2977: # Returns:
2978: # 1 - Continue processing.
2979: # 0 - Exit the server.
2980: #
2981: sub dump_profile_database {
2982: my ($cmd, $tail, $client) = @_;
2983:
2984: my $userinput = "$cmd:$tail";
2985:
2986: my ($udom,$uname,$namespace) = split(/:/,$tail);
2987: my $hashref = &tie_user_hash($udom, $uname, $namespace,
2988: &GDBM_READER());
2989: if ($hashref) {
2990: # Structure of %data:
2991: # $data{$symb}->{$parameter}=$value;
2992: # $data{$symb}->{'v.'.$parameter}=$version;
2993: # since $parameter will be unescaped, we do not
2994: # have to worry about silly parameter names...
2995:
2996: my $qresult='';
2997: my %data = (); # A hash of anonymous hashes..
2998: while (my ($key,$value) = each(%$hashref)) {
2999: my ($v,$symb,$param) = split(/:/,$key);
3000: next if ($v eq 'version' || $symb eq 'keys');
3001: next if (exists($data{$symb}) &&
3002: exists($data{$symb}->{$param}) &&
3003: $data{$symb}->{'v.'.$param} > $v);
3004: $data{$symb}->{$param}=$value;
3005: $data{$symb}->{'v.'.$param}=$v;
3006: }
1.311 albertel 3007: if (&untie_user_hash($hashref)) {
1.231 foxr 3008: while (my ($symb,$param_hash) = each(%data)) {
3009: while(my ($param,$value) = each (%$param_hash)){
3010: next if ($param =~ /^v\./); # Ignore versions...
3011: #
3012: # Just dump the symb=value pairs separated by &
3013: #
3014: $qresult.=$symb.':'.$param.'='.$value.'&';
3015: }
3016: }
3017: chop($qresult);
1.387 albertel 3018: &Reply($client , \$qresult, $userinput);
1.231 foxr 3019: } else {
3020: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
3021: "while attempting currentdump\n", $userinput);
3022: }
3023: } else {
3024: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
3025: "while attempting currentdump\n", $userinput);
3026: }
3027:
3028: return 1;
3029: }
3030: ®ister_handler("currentdump", \&dump_profile_database, 0, 1, 0);
3031:
3032: #
3033: # Dump a profile database with an optional regular expression
3034: # to match against the keys. In this dump, no effort is made
3035: # to separate symb from version information. Presumably the
3036: # databases that are dumped by this command are of a different
3037: # structure. Need to look at this and improve the documentation of
3038: # both this and the currentdump handler.
3039: # Parameters:
3040: # $cmd - The command keyword.
3041: # $tail - All of the characters after the $cmd:
3042: # These are expected to be a colon
3043: # separated list containing:
3044: # domain/user - identifying the user.
3045: # namespace - identifying the database.
3046: # regexp - optional regular expression
3047: # that is matched against
3048: # database keywords to do
3049: # selective dumps.
3050: # $client - Channel open on the client.
3051: # Returns:
3052: # 1 - Continue processing.
3053: # Side effects:
3054: # response is written to $client.
3055: #
3056: sub dump_with_regexp {
3057: my ($cmd, $tail, $client) = @_;
3058:
3059:
3060: my $userinput = "$cmd:$tail";
3061:
1.306 albertel 3062: my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
1.231 foxr 3063: if (defined($regexp)) {
3064: $regexp=&unescape($regexp);
3065: } else {
3066: $regexp='.';
3067: }
1.306 albertel 3068: my ($start,$end);
3069: if (defined($range)) {
3070: if ($range =~/^(\d+)\-(\d+)$/) {
3071: ($start,$end) = ($1,$2);
3072: } elsif ($range =~/^(\d+)$/) {
3073: ($start,$end) = (0,$1);
3074: } else {
3075: undef($range);
3076: }
3077: }
1.231 foxr 3078: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3079: &GDBM_READER());
3080: if ($hashref) {
3081: my $qresult='';
1.306 albertel 3082: my $count=0;
1.231 foxr 3083: while (my ($key,$value) = each(%$hashref)) {
3084: if ($regexp eq '.') {
1.306 albertel 3085: $count++;
3086: if (defined($range) && $count >= $end) { last; }
3087: if (defined($range) && $count < $start) { next; }
1.231 foxr 3088: $qresult.=$key.'='.$value.'&';
3089: } else {
3090: my $unescapeKey = &unescape($key);
3091: if (eval('$unescapeKey=~/$regexp/')) {
1.306 albertel 3092: $count++;
3093: if (defined($range) && $count >= $end) { last; }
3094: if (defined($range) && $count < $start) { next; }
1.231 foxr 3095: $qresult.="$key=$value&";
3096: }
3097: }
3098: }
1.311 albertel 3099: if (&untie_user_hash($hashref)) {
1.231 foxr 3100: chop($qresult);
1.387 albertel 3101: &Reply($client, \$qresult, $userinput);
1.231 foxr 3102: } else {
3103: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
3104: "while attempting dump\n", $userinput);
3105: }
3106: } else {
3107: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
3108: "while attempting dump\n", $userinput);
3109: }
3110:
3111: return 1;
3112: }
3113: ®ister_handler("dump", \&dump_with_regexp, 0, 1, 0);
3114:
3115: # Store a set of key=value pairs associated with a versioned name.
3116: #
3117: # Parameters:
3118: # $cmd - Request command keyword.
3119: # $tail - Tail of the request. This is a colon
3120: # separated list containing:
3121: # domain/user - User and authentication domain.
3122: # namespace - Name of the database being modified
3123: # rid - Resource keyword to modify.
3124: # what - new value associated with rid.
3125: #
3126: # $client - Socket open on the client.
3127: #
3128: #
3129: # Returns:
3130: # 1 (keep on processing).
3131: # Side-Effects:
3132: # Writes to the client
3133: sub store_handler {
3134: my ($cmd, $tail, $client) = @_;
3135:
3136: my $userinput = "$cmd:$tail";
3137:
3138: my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);
3139: if ($namespace ne 'roles') {
3140:
3141: chomp($what);
3142: my @pairs=split(/\&/,$what);
3143: my $hashref = &tie_user_hash($udom, $uname, $namespace,
1.268 albertel 3144: &GDBM_WRCREAT(), "S",
1.231 foxr 3145: "$rid:$what");
3146: if ($hashref) {
3147: my $now = time;
3148: my @previouskeys=split(/&/,$hashref->{"keys:$rid"});
3149: my $key;
3150: $hashref->{"version:$rid"}++;
3151: my $version=$hashref->{"version:$rid"};
3152: my $allkeys='';
3153: foreach my $pair (@pairs) {
3154: my ($key,$value)=split(/=/,$pair);
3155: $allkeys.=$key.':';
3156: $hashref->{"$version:$rid:$key"}=$value;
3157: }
3158: $hashref->{"$version:$rid:timestamp"}=$now;
3159: $allkeys.='timestamp';
3160: $hashref->{"$version:keys:$rid"}=$allkeys;
1.311 albertel 3161: if (&untie_user_hash($hashref)) {
1.231 foxr 3162: &Reply($client, "ok\n", $userinput);
3163: } else {
3164: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3165: "while attempting store\n", $userinput);
3166: }
3167: } else {
3168: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3169: "while attempting store\n", $userinput);
3170: }
3171: } else {
3172: &Failure($client, "refused\n", $userinput);
3173: }
3174:
3175: return 1;
3176: }
3177: ®ister_handler("store", \&store_handler, 0, 1, 0);
1.263 albertel 3178:
1.323 albertel 3179: # Modify a set of key=value pairs associated with a versioned name.
3180: #
3181: # Parameters:
3182: # $cmd - Request command keyword.
3183: # $tail - Tail of the request. This is a colon
3184: # separated list containing:
3185: # domain/user - User and authentication domain.
3186: # namespace - Name of the database being modified
3187: # rid - Resource keyword to modify.
3188: # v - Version item to modify
3189: # what - new value associated with rid.
3190: #
3191: # $client - Socket open on the client.
3192: #
3193: #
3194: # Returns:
3195: # 1 (keep on processing).
3196: # Side-Effects:
3197: # Writes to the client
3198: sub putstore_handler {
3199: my ($cmd, $tail, $client) = @_;
3200:
3201: my $userinput = "$cmd:$tail";
3202:
3203: my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail);
3204: if ($namespace ne 'roles') {
3205:
3206: chomp($what);
3207: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3208: &GDBM_WRCREAT(), "M",
3209: "$rid:$v:$what");
3210: if ($hashref) {
3211: my $now = time;
3212: my %data = &hash_extract($what);
3213: my @allkeys;
3214: while (my($key,$value) = each(%data)) {
3215: push(@allkeys,$key);
3216: $hashref->{"$v:$rid:$key"} = $value;
3217: }
3218: my $allkeys = join(':',@allkeys);
3219: $hashref->{"$v:keys:$rid"}=$allkeys;
3220:
3221: if (&untie_user_hash($hashref)) {
3222: &Reply($client, "ok\n", $userinput);
3223: } else {
3224: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3225: "while attempting store\n", $userinput);
3226: }
3227: } else {
3228: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3229: "while attempting store\n", $userinput);
3230: }
3231: } else {
3232: &Failure($client, "refused\n", $userinput);
3233: }
3234:
3235: return 1;
3236: }
3237: ®ister_handler("putstore", \&putstore_handler, 0, 1, 0);
3238:
3239: sub hash_extract {
3240: my ($str)=@_;
3241: my %hash;
3242: foreach my $pair (split(/\&/,$str)) {
3243: my ($key,$value)=split(/=/,$pair);
3244: $hash{$key}=$value;
3245: }
3246: return (%hash);
3247: }
3248: sub hash_to_str {
3249: my ($hash_ref)=@_;
3250: my $str;
3251: foreach my $key (keys(%$hash_ref)) {
3252: $str.=$key.'='.$hash_ref->{$key}.'&';
3253: }
3254: $str=~s/\&$//;
3255: return $str;
3256: }
3257:
1.231 foxr 3258: #
3259: # Dump out all versions of a resource that has key=value pairs associated
3260: # with it for each version. These resources are built up via the store
3261: # command.
3262: #
3263: # Parameters:
3264: # $cmd - Command keyword.
3265: # $tail - Remainder of the request which consists of:
3266: # domain/user - User and auth. domain.
3267: # namespace - name of resource database.
3268: # rid - Resource id.
3269: # $client - socket open on the client.
3270: #
3271: # Returns:
3272: # 1 indicating the caller should not yet exit.
3273: # Side-effects:
3274: # Writes a reply to the client.
3275: # The reply is a string of the following shape:
3276: # version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2...
3277: # Where the 1 above represents version 1.
3278: # this continues for all pairs of keys in all versions.
3279: #
3280: #
3281: #
3282: #
3283: sub restore_handler {
3284: my ($cmd, $tail, $client) = @_;
3285:
3286: my $userinput = "$cmd:$tail"; # Only used for logging purposes.
1.351 banghart 3287: my ($udom,$uname,$namespace,$rid) = split(/:/,$tail);
1.352 albertel 3288: $namespace=~s/\//\_/g;
1.350 albertel 3289: $namespace = &LONCAPA::clean_username($namespace);
1.349 albertel 3290:
1.231 foxr 3291: chomp($rid);
3292: my $qresult='';
1.309 albertel 3293: my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
3294: if ($hashref) {
3295: my $version=$hashref->{"version:$rid"};
1.231 foxr 3296: $qresult.="version=$version&";
3297: my $scope;
3298: for ($scope=1;$scope<=$version;$scope++) {
1.309 albertel 3299: my $vkeys=$hashref->{"$scope:keys:$rid"};
1.231 foxr 3300: my @keys=split(/:/,$vkeys);
3301: my $key;
3302: $qresult.="$scope:keys=$vkeys&";
3303: foreach $key (@keys) {
1.309 albertel 3304: $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
1.231 foxr 3305: }
3306: }
1.311 albertel 3307: if (&untie_user_hash($hashref)) {
1.231 foxr 3308: $qresult=~s/\&$//;
1.387 albertel 3309: &Reply( $client, \$qresult, $userinput);
1.231 foxr 3310: } else {
3311: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3312: "while attempting restore\n", $userinput);
3313: }
3314: } else {
3315: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
3316: "while attempting restore\n", $userinput);
3317: }
3318:
3319: return 1;
3320:
3321:
3322: }
3323: ®ister_handler("restore", \&restore_handler, 0,1,0);
1.234 foxr 3324:
3325: #
1.324 raeburn 3326: # Add a chat message to a synchronous discussion board.
1.234 foxr 3327: #
3328: # Parameters:
3329: # $cmd - Request keyword.
3330: # $tail - Tail of the command. A colon separated list
3331: # containing:
3332: # cdom - Domain on which the chat board lives
1.324 raeburn 3333: # cnum - Course containing the chat board.
3334: # newpost - Body of the posting.
3335: # group - Optional group, if chat board is only
3336: # accessible in a group within the course
1.234 foxr 3337: # $client - Socket open on the client.
3338: # Returns:
3339: # 1 - Indicating caller should keep on processing.
3340: #
3341: # Side-effects:
3342: # writes a reply to the client.
3343: #
3344: #
3345: sub send_chat_handler {
3346: my ($cmd, $tail, $client) = @_;
3347:
3348:
3349: my $userinput = "$cmd:$tail";
3350:
1.324 raeburn 3351: my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail);
3352: &chat_add($cdom,$cnum,$newpost,$group);
1.234 foxr 3353: &Reply($client, "ok\n", $userinput);
3354:
3355: return 1;
3356: }
3357: ®ister_handler("chatsend", \&send_chat_handler, 0, 1, 0);
1.263 albertel 3358:
1.234 foxr 3359: #
1.324 raeburn 3360: # Retrieve the set of chat messages from a discussion board.
1.234 foxr 3361: #
3362: # Parameters:
3363: # $cmd - Command keyword that initiated the request.
3364: # $tail - Remainder of the request after the command
3365: # keyword. In this case a colon separated list of
3366: # chat domain - Which discussion board.
3367: # chat id - Discussion thread(?)
3368: # domain/user - Authentication domain and username
3369: # of the requesting person.
1.324 raeburn 3370: # group - Optional course group containing
3371: # the board.
1.234 foxr 3372: # $client - Socket open on the client program.
3373: # Returns:
3374: # 1 - continue processing
3375: # Side effects:
3376: # Response is written to the client.
3377: #
3378: sub retrieve_chat_handler {
3379: my ($cmd, $tail, $client) = @_;
3380:
3381:
3382: my $userinput = "$cmd:$tail";
3383:
1.324 raeburn 3384: my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail);
1.234 foxr 3385: my $reply='';
1.324 raeburn 3386: foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) {
1.234 foxr 3387: $reply.=&escape($_).':';
3388: }
3389: $reply=~s/\:$//;
1.387 albertel 3390: &Reply($client, \$reply, $userinput);
1.234 foxr 3391:
3392:
3393: return 1;
3394: }
3395: ®ister_handler("chatretr", \&retrieve_chat_handler, 0, 1, 0);
3396:
3397: #
3398: # Initiate a query of an sql database. SQL query repsonses get put in
3399: # a file for later retrieval. This prevents sql query results from
3400: # bottlenecking the system. Note that with loncnew, perhaps this is
3401: # less of an issue since multiple outstanding requests can be concurrently
3402: # serviced.
3403: #
3404: # Parameters:
3405: # $cmd - COmmand keyword that initiated the request.
3406: # $tail - Remainder of the command after the keyword.
3407: # For this function, this consists of a query and
3408: # 3 arguments that are self-documentingly labelled
3409: # in the original arg1, arg2, arg3.
3410: # $client - Socket open on the client.
3411: # Return:
3412: # 1 - Indicating processing should continue.
3413: # Side-effects:
3414: # a reply is written to $client.
3415: #
3416: sub send_query_handler {
3417: my ($cmd, $tail, $client) = @_;
3418:
3419:
3420: my $userinput = "$cmd:$tail";
3421:
3422: my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);
3423: $query=~s/\n*$//g;
3424: &Reply($client, "". &sql_reply("$clientname\&$query".
3425: "\&$arg1"."\&$arg2"."\&$arg3")."\n",
3426: $userinput);
3427:
3428: return 1;
3429: }
3430: ®ister_handler("querysend", \&send_query_handler, 0, 1, 0);
3431:
3432: #
3433: # Add a reply to an sql query. SQL queries are done asyncrhonously.
3434: # The query is submitted via a "querysend" transaction.
3435: # There it is passed on to the lonsql daemon, queued and issued to
3436: # mysql.
3437: # This transaction is invoked when the sql transaction is complete
3438: # it stores the query results in flie and indicates query completion.
3439: # presumably local software then fetches this response... I'm guessing
3440: # the sequence is: lonc does a querysend, we ask lonsql to do it.
3441: # lonsql on completion of the query interacts with the lond of our
3442: # client to do a query reply storing two files:
3443: # - id - The results of the query.
3444: # - id.end - Indicating the transaction completed.
3445: # NOTE: id is a unique id assigned to the query and querysend time.
3446: # Parameters:
3447: # $cmd - Command keyword that initiated this request.
3448: # $tail - Remainder of the tail. In this case that's a colon
3449: # separated list containing the query Id and the
3450: # results of the query.
3451: # $client - Socket open on the client.
3452: # Return:
3453: # 1 - Indicating that we should continue processing.
3454: # Side effects:
3455: # ok written to the client.
3456: #
3457: sub reply_query_handler {
3458: my ($cmd, $tail, $client) = @_;
3459:
3460:
3461: my $userinput = "$cmd:$tail";
3462:
1.339 albertel 3463: my ($id,$reply)=split(/:/,$tail);
1.234 foxr 3464: my $store;
3465: my $execdir=$perlvar{'lonDaemons'};
3466: if ($store=IO::File->new(">$execdir/tmp/$id")) {
3467: $reply=~s/\&/\n/g;
3468: print $store $reply;
3469: close $store;
3470: my $store2=IO::File->new(">$execdir/tmp/$id.end");
3471: print $store2 "done\n";
3472: close $store2;
3473: &Reply($client, "ok\n", $userinput);
3474: } else {
3475: &Failure($client, "error: ".($!+0)
3476: ." IO::File->new Failed ".
3477: "while attempting queryreply\n", $userinput);
3478: }
3479:
3480:
3481: return 1;
3482: }
3483: ®ister_handler("queryreply", \&reply_query_handler, 0, 1, 0);
3484:
3485: #
3486: # Process the courseidput request. Not quite sure what this means
3487: # at the system level sense. It appears a gdbm file in the
3488: # /home/httpd/lonUsers/$domain/nohist_courseids is tied and
3489: # a set of entries made in that database.
3490: #
3491: # Parameters:
3492: # $cmd - The command keyword that initiated this request.
3493: # $tail - Tail of the command. In this case consists of a colon
3494: # separated list contaning the domain to apply this to and
3495: # an ampersand separated list of keyword=value pairs.
1.272 raeburn 3496: # Each value is a colon separated list that includes:
3497: # description, institutional code and course owner.
3498: # For backward compatibility with versions included
3499: # in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional
3500: # code and/or course owner are preserved from the existing
3501: # record when writing a new record in response to 1.1 or
3502: # 1.2 implementations of lonnet::flushcourselogs().
3503: #
1.234 foxr 3504: # $client - Socket open on the client.
3505: # Returns:
3506: # 1 - indicating that processing should continue
3507: #
3508: # Side effects:
3509: # reply is written to the client.
3510: #
3511: sub put_course_id_handler {
3512: my ($cmd, $tail, $client) = @_;
3513:
3514:
3515: my $userinput = "$cmd:$tail";
3516:
1.266 raeburn 3517: my ($udom, $what) = split(/:/, $tail,2);
1.234 foxr 3518: chomp($what);
3519: my $now=time;
3520: my @pairs=split(/\&/,$what);
3521:
3522: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
3523: if ($hashref) {
3524: foreach my $pair (@pairs) {
1.271 raeburn 3525: my ($key,$courseinfo) = split(/=/,$pair,2);
3526: $courseinfo =~ s/=/:/g;
1.384 raeburn 3527: if (defined($hashref->{$key})) {
3528: my $value = &Apache::lonnet::thaw_unescape($hashref->{$key});
3529: if (ref($value) eq 'HASH') {
3530: my @items = ('description','inst_code','owner','type');
3531: my @new_items = split(/:/,$courseinfo,-1);
3532: my %storehash;
3533: for (my $i=0; $i<@new_items; $i++) {
1.391 raeburn 3534: $storehash{$items[$i]} = &unescape($new_items[$i]);
1.384 raeburn 3535: }
3536: $hashref->{$key} =
3537: &Apache::lonnet::freeze_escape(\%storehash);
3538: my $unesc_key = &unescape($key);
3539: $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
3540: next;
1.383 raeburn 3541: }
1.384 raeburn 3542: }
3543: my @current_items = split(/:/,$hashref->{$key},-1);
3544: shift(@current_items); # remove description
3545: pop(@current_items); # remove last access
3546: my $numcurrent = scalar(@current_items);
3547: if ($numcurrent > 3) {
3548: $numcurrent = 3;
3549: }
3550: my @new_items = split(/:/,$courseinfo,-1);
3551: my $numnew = scalar(@new_items);
3552: if ($numcurrent > 0) {
3553: if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2
3554: for (my $j=$numcurrent-$numnew; $j>=0; $j--) {
3555: $courseinfo .= ':'.$current_items[$numcurrent-$j-1];
1.333 raeburn 3556: }
1.272 raeburn 3557: }
3558: }
1.384 raeburn 3559: $hashref->{$key}=$courseinfo.':'.$now;
1.234 foxr 3560: }
1.311 albertel 3561: if (&untie_domain_hash($hashref)) {
1.253 foxr 3562: &Reply( $client, "ok\n", $userinput);
1.234 foxr 3563: } else {
1.253 foxr 3564: &Failure($client, "error: ".($!+0)
1.234 foxr 3565: ." untie(GDBM) Failed ".
3566: "while attempting courseidput\n", $userinput);
3567: }
3568: } else {
1.253 foxr 3569: &Failure($client, "error: ".($!+0)
1.234 foxr 3570: ." tie(GDBM) Failed ".
3571: "while attempting courseidput\n", $userinput);
3572: }
3573:
3574: return 1;
3575: }
3576: ®ister_handler("courseidput", \&put_course_id_handler, 0, 1, 0);
3577:
1.383 raeburn 3578: sub put_course_id_hash_handler {
3579: my ($cmd, $tail, $client) = @_;
3580: my $userinput = "$cmd:$tail";
1.384 raeburn 3581: my ($udom,$mode,$what) = split(/:/, $tail,3);
1.383 raeburn 3582: chomp($what);
3583: my $now=time;
3584: my @pairs=split(/\&/,$what);
1.384 raeburn 3585: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
1.383 raeburn 3586: if ($hashref) {
3587: foreach my $pair (@pairs) {
3588: my ($key,$value)=split(/=/,$pair);
1.384 raeburn 3589: my $unesc_key = &unescape($key);
3590: if ($mode ne 'timeonly') {
3591: if (!defined($hashref->{&escape('lasttime:'.$unesc_key)})) {
3592: my $curritems = &Apache::lonnet::thaw_unescape($key);
3593: if (ref($curritems) ne 'HASH') {
3594: my @current_items = split(/:/,$hashref->{$key},-1);
3595: my $lasttime = pop(@current_items);
3596: $hashref->{&escape('lasttime:'.$unesc_key)} = $lasttime;
3597: } else {
3598: $hashref->{&escape('lasttime:'.$unesc_key)} = '';
3599: }
3600: }
3601: $hashref->{$key} = $value;
3602: }
3603: if ($mode ne 'notime') {
3604: $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
3605: }
1.383 raeburn 3606: }
3607: if (&untie_domain_hash($hashref)) {
3608: &Reply($client, "ok\n", $userinput);
3609: } else {
3610: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3611: "while attempting courseidputhash\n", $userinput);
3612: }
3613: } else {
3614: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3615: "while attempting courseidputhash\n", $userinput);
3616: }
3617: return 1;
3618: }
3619: ®ister_handler("courseidputhash", \&put_course_id_hash_handler, 0, 1, 0);
3620:
1.234 foxr 3621: # Retrieves the value of a course id resource keyword pattern
3622: # defined since a starting date. Both the starting date and the
3623: # keyword pattern are optional. If the starting date is not supplied it
3624: # is treated as the beginning of time. If the pattern is not found,
3625: # it is treatred as "." matching everything.
3626: #
3627: # Parameters:
3628: # $cmd - Command keyword that resulted in us being dispatched.
3629: # $tail - The remainder of the command that, in this case, consists
3630: # of a colon separated list of:
3631: # domain - The domain in which the course database is
3632: # defined.
3633: # since - Optional parameter describing the minimum
3634: # time of definition(?) of the resources that
3635: # will match the dump.
3636: # description - regular expression that is used to filter
3637: # the dump. Only keywords matching this regexp
3638: # will be used.
1.272 raeburn 3639: # institutional code - optional supplied code to filter
3640: # the dump. Only courses with an institutional code
3641: # that match the supplied code will be returned.
1.336 raeburn 3642: # owner - optional supplied username and domain of owner to
3643: # filter the dump. Only courses for which the course
3644: # owner matches the supplied username and/or domain
3645: # will be returned. Pre-2.2.0 legacy entries from
3646: # nohist_courseiddump will only contain usernames.
1.384 raeburn 3647: # type - optional parameter for selection
3648: # regexp_ok - if true, allow the supplied institutional code
3649: # filter to behave as a regular expression.
3650: # rtn_as_hash - whether to return the information available for
3651: # each matched item as a frozen hash of all
3652: # key, value pairs in the item's hash, or as a
3653: # colon-separated list of (in order) description,
3654: # institutional code, and course owner.
1.404 raeburn 3655: # selfenrollonly - filter by courses allowing self-enrollment
3656: # now or in the future (selfenrollonly = 1).
3657: # catfilter - filter by course category, assigned to a course
3658: # using manually defined categories (i.e., not
1.407 raeburn 3659: # self-cataloging based on on institutional code).
1.404 raeburn 3660: # showhidden - include course in results even if course
1.407 raeburn 3661: # was set to be excluded from course catalog (DC only).
1.404 raeburn 3662: # caller - if set to 'coursecatalog', courses set to be hidden
3663: # from course catalog will be excluded from results (unless
3664: # overridden by "showhidden".
3665: #
1.234 foxr 3666: # $client - The socket open on the client.
3667: # Returns:
3668: # 1 - Continue processing.
3669: # Side Effects:
3670: # a reply is written to $client.
3671: sub dump_course_id_handler {
3672: my ($cmd, $tail, $client) = @_;
3673: my $userinput = "$cmd:$tail";
3674:
1.333 raeburn 3675: my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
1.404 raeburn 3676: $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
3677: $caller) =split(/:/,$tail);
1.397 raeburn 3678: my $now = time;
1.234 foxr 3679: if (defined($description)) {
3680: $description=&unescape($description);
3681: } else {
3682: $description='.';
3683: }
1.266 raeburn 3684: if (defined($instcodefilter)) {
3685: $instcodefilter=&unescape($instcodefilter);
3686: } else {
3687: $instcodefilter='.';
3688: }
1.336 raeburn 3689: my ($ownerunamefilter,$ownerdomfilter);
1.266 raeburn 3690: if (defined($ownerfilter)) {
3691: $ownerfilter=&unescape($ownerfilter);
1.336 raeburn 3692: if ($ownerfilter ne '.' && defined($ownerfilter)) {
3693: if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
3694: $ownerunamefilter = $1;
3695: $ownerdomfilter = $2;
3696: } else {
3697: $ownerunamefilter = $ownerfilter;
3698: $ownerdomfilter = '';
3699: }
3700: }
1.266 raeburn 3701: } else {
3702: $ownerfilter='.';
3703: }
1.336 raeburn 3704:
1.282 raeburn 3705: if (defined($coursefilter)) {
3706: $coursefilter=&unescape($coursefilter);
3707: } else {
3708: $coursefilter='.';
3709: }
1.333 raeburn 3710: if (defined($typefilter)) {
3711: $typefilter=&unescape($typefilter);
3712: } else {
3713: $typefilter='.';
3714: }
1.344 raeburn 3715: if (defined($regexp_ok)) {
3716: $regexp_ok=&unescape($regexp_ok);
3717: }
1.401 raeburn 3718: if (defined($catfilter)) {
3719: $catfilter=&unescape($catfilter);
3720: }
1.384 raeburn 3721: my $unpack = 1;
3722: if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
3723: $typefilter eq '.') {
3724: $unpack = 0;
3725: }
3726: if (!defined($since)) { $since=0; }
1.234 foxr 3727: my $qresult='';
3728: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
3729: if ($hashref) {
1.384 raeburn 3730: while (my ($key,$value) = each(%$hashref)) {
1.397 raeburn 3731: my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
1.398 raeburn 3732: %unesc_val,$selfenroll_end,$selfenroll_types);
1.384 raeburn 3733: $unesc_key = &unescape($key);
3734: if ($unesc_key =~ /^lasttime:/) {
3735: next;
3736: } else {
3737: $lasttime_key = &escape('lasttime:'.$unesc_key);
3738: }
3739: if ($hashref->{$lasttime_key} ne '') {
3740: $lasttime = $hashref->{$lasttime_key};
3741: next if ($lasttime<$since);
3742: }
3743: my $items = &Apache::lonnet::thaw_unescape($value);
3744: if (ref($items) eq 'HASH') {
3745: $is_hash = 1;
3746: if ($unpack || !$rtn_as_hash) {
3747: $unesc_val{'descr'} = $items->{'description'};
3748: $unesc_val{'inst_code'} = $items->{'inst_code'};
3749: $unesc_val{'owner'} = $items->{'owner'};
3750: $unesc_val{'type'} = $items->{'type'};
1.404 raeburn 3751: }
3752: $selfenroll_types = $items->{'selfenroll_types'};
3753: $selfenroll_end = $items->{'selfenroll_end_date'};
3754: if ($selfenrollonly) {
3755: next if (!$selfenroll_types);
3756: if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
3757: next;
1.397 raeburn 3758: }
1.404 raeburn 3759: }
3760: if ($catfilter ne '') {
1.406 raeburn 3761: next if ($items->{'categories'} eq '');
3762: my @categories = split('&',$items->{'categories'});
1.407 raeburn 3763: next if (@categories == 0);
3764: my @subcats = split('&',$catfilter);
3765: my $matchcat = 0;
3766: foreach my $cat (@categories) {
3767: if (grep(/^\Q$cat\E$/,@subcats)) {
3768: $matchcat = 1;
3769: last;
3770: }
3771: }
3772: next if (!$matchcat);
1.404 raeburn 3773: }
3774: if ($caller eq 'coursecatalog') {
1.405 raeburn 3775: if ($items->{'hidefromcat'} eq 'yes') {
3776: next if !$showhidden;
1.401 raeburn 3777: }
1.384 raeburn 3778: }
1.383 raeburn 3779: } else {
1.401 raeburn 3780: next if ($catfilter ne '');
3781: next if ($selfenrollonly);
1.384 raeburn 3782: $is_hash = 0;
1.388 raeburn 3783: my @courseitems = split(/:/,$value);
1.403 raeburn 3784: $lasttime = pop(@courseitems);
1.402 raeburn 3785: if ($hashref->{$lasttime_key} eq '') {
3786: next if ($lasttime<$since);
3787: }
1.384 raeburn 3788: ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
1.383 raeburn 3789: }
1.266 raeburn 3790: my $match = 1;
1.384 raeburn 3791: if ($description ne '.') {
3792: if (!$is_hash) {
3793: $unesc_val{'descr'} = &unescape($val{'descr'});
3794: }
3795: if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
1.266 raeburn 3796: $match = 0;
1.384 raeburn 3797: }
1.266 raeburn 3798: }
1.384 raeburn 3799: if ($instcodefilter ne '.') {
3800: if (!$is_hash) {
3801: $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
3802: }
1.344 raeburn 3803: if ($regexp_ok) {
1.384 raeburn 3804: if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
1.344 raeburn 3805: $match = 0;
3806: }
3807: } else {
1.384 raeburn 3808: if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
1.344 raeburn 3809: $match = 0;
3810: }
1.266 raeburn 3811: }
1.234 foxr 3812: }
1.384 raeburn 3813: if ($ownerfilter ne '.') {
3814: if (!$is_hash) {
3815: $unesc_val{'owner'} = &unescape($val{'owner'});
3816: }
1.336 raeburn 3817: if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
1.384 raeburn 3818: if ($unesc_val{'owner'} =~ /:/) {
3819: if (eval{$unesc_val{'owner'} !~
3820: /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
1.336 raeburn 3821: $match = 0;
3822: }
3823: } else {
1.384 raeburn 3824: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
1.336 raeburn 3825: $match = 0;
3826: }
3827: }
3828: } elsif ($ownerunamefilter ne '') {
1.384 raeburn 3829: if ($unesc_val{'owner'} =~ /:/) {
3830: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
1.336 raeburn 3831: $match = 0;
3832: }
3833: } else {
1.384 raeburn 3834: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
1.336 raeburn 3835: $match = 0;
3836: }
3837: }
3838: } elsif ($ownerdomfilter ne '') {
1.384 raeburn 3839: if ($unesc_val{'owner'} =~ /:/) {
3840: if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
1.336 raeburn 3841: $match = 0;
3842: }
3843: } else {
3844: if ($ownerdomfilter ne $udom) {
3845: $match = 0;
3846: }
3847: }
1.266 raeburn 3848: }
3849: }
1.384 raeburn 3850: if ($coursefilter ne '.') {
3851: if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
1.282 raeburn 3852: $match = 0;
3853: }
3854: }
1.384 raeburn 3855: if ($typefilter ne '.') {
3856: if (!$is_hash) {
3857: $unesc_val{'type'} = &unescape($val{'type'});
3858: }
3859: if ($unesc_val{'type'} eq '') {
1.333 raeburn 3860: if ($typefilter ne 'Course') {
3861: $match = 0;
3862: }
1.383 raeburn 3863: } else {
1.384 raeburn 3864: if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
1.333 raeburn 3865: $match = 0;
3866: }
3867: }
3868: }
1.266 raeburn 3869: if ($match == 1) {
1.384 raeburn 3870: if ($rtn_as_hash) {
3871: if ($is_hash) {
3872: $qresult.=$key.'='.$value.'&';
3873: } else {
1.388 raeburn 3874: my %rtnhash = ( 'description' => &unescape($val{'descr'}),
3875: 'inst_code' => &unescape($val{'inst_code'}),
3876: 'owner' => &unescape($val{'owner'}),
3877: 'type' => &unescape($val{'type'}),
1.384 raeburn 3878: );
3879: my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
3880: $qresult.=$key.'='.$items.'&';
3881: }
1.383 raeburn 3882: } else {
1.384 raeburn 3883: if ($is_hash) {
3884: $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
3885: &escape($unesc_val{'inst_code'}).':'.
3886: &escape($unesc_val{'owner'}).'&';
3887: } else {
3888: $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
3889: ':'.$val{'owner'}.'&';
3890: }
1.383 raeburn 3891: }
1.266 raeburn 3892: }
1.234 foxr 3893: }
1.311 albertel 3894: if (&untie_domain_hash($hashref)) {
1.234 foxr 3895: chop($qresult);
1.387 albertel 3896: &Reply($client, \$qresult, $userinput);
1.234 foxr 3897: } else {
3898: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3899: "while attempting courseiddump\n", $userinput);
3900: }
3901: } else {
3902: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
3903: "while attempting courseiddump\n", $userinput);
3904: }
3905: return 1;
3906: }
3907: ®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
1.238 foxr 3908:
3909: #
1.348 raeburn 3910: # Puts an unencrypted entry in a namespace db file at the domain level
3911: #
3912: # Parameters:
3913: # $cmd - The command that got us here.
3914: # $tail - Tail of the command (remaining parameters).
3915: # $client - File descriptor connected to client.
3916: # Returns
3917: # 0 - Requested to exit, caller should shut down.
3918: # 1 - Continue processing.
3919: # Side effects:
3920: # reply is written to $client.
3921: #
3922: sub put_domain_handler {
3923: my ($cmd,$tail,$client) = @_;
3924:
3925: my $userinput = "$cmd:$tail";
3926:
3927: my ($udom,$namespace,$what) =split(/:/,$tail,3);
3928: chomp($what);
3929: my @pairs=split(/\&/,$what);
3930: my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(),
3931: "P", $what);
3932: if ($hashref) {
3933: foreach my $pair (@pairs) {
3934: my ($key,$value)=split(/=/,$pair);
3935: $hashref->{$key}=$value;
3936: }
3937: if (&untie_domain_hash($hashref)) {
3938: &Reply($client, "ok\n", $userinput);
3939: } else {
3940: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3941: "while attempting putdom\n", $userinput);
3942: }
3943: } else {
3944: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3945: "while attempting putdom\n", $userinput);
3946: }
3947:
3948: return 1;
3949: }
3950: ®ister_handler("putdom", \&put_domain_handler, 0, 1, 0);
3951:
3952: # Unencrypted get from the namespace database file at the domain level.
3953: # This function retrieves a keyed item from a specific named database in the
3954: # domain directory.
3955: #
3956: # Parameters:
3957: # $cmd - Command request keyword (get).
3958: # $tail - Tail of the command. This is a colon separated list
3959: # consisting of the domain and the 'namespace'
3960: # which selects the gdbm file to do the lookup in,
3961: # & separated list of keys to lookup. Note that
3962: # the values are returned as an & separated list too.
3963: # $client - File descriptor open on the client.
3964: # Returns:
3965: # 1 - Continue processing.
3966: # 0 - Exit.
3967: # Side effects:
3968: # reply is written to $client.
3969: #
3970:
3971: sub get_domain_handler {
3972: my ($cmd, $tail, $client) = @_;
3973:
3974: my $userinput = "$client:$tail";
3975:
3976: my ($udom,$namespace,$what)=split(/:/,$tail,3);
3977: chomp($what);
3978: my @queries=split(/\&/,$what);
3979: my $qresult='';
3980: my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER());
3981: if ($hashref) {
3982: for (my $i=0;$i<=$#queries;$i++) {
3983: $qresult.="$hashref->{$queries[$i]}&";
3984: }
3985: if (&untie_domain_hash($hashref)) {
3986: $qresult=~s/\&$//;
1.387 albertel 3987: &Reply($client, \$qresult, $userinput);
1.348 raeburn 3988: } else {
3989: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
3990: "while attempting getdom\n",$userinput);
3991: }
3992: } else {
3993: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
3994: "while attempting getdom\n",$userinput);
3995: }
3996:
3997: return 1;
3998: }
1.360 raeburn 3999: ®ister_handler("getdom", \&get_domain_handler, 0, 1, 0);
1.348 raeburn 4000:
4001:
4002: #
1.238 foxr 4003: # Puts an id to a domains id database.
4004: #
4005: # Parameters:
4006: # $cmd - The command that triggered us.
4007: # $tail - Remainder of the request other than the command. This is a
4008: # colon separated list containing:
4009: # $domain - The domain for which we are writing the id.
4010: # $pairs - The id info to write... this is and & separated list
4011: # of keyword=value.
4012: # $client - Socket open on the client.
4013: # Returns:
4014: # 1 - Continue processing.
4015: # Side effects:
4016: # reply is written to $client.
4017: #
4018: sub put_id_handler {
4019: my ($cmd,$tail,$client) = @_;
4020:
4021:
4022: my $userinput = "$cmd:$tail";
4023:
4024: my ($udom,$what)=split(/:/,$tail);
4025: chomp($what);
4026: my @pairs=split(/\&/,$what);
4027: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(),
4028: "P", $what);
4029: if ($hashref) {
4030: foreach my $pair (@pairs) {
4031: my ($key,$value)=split(/=/,$pair);
4032: $hashref->{$key}=$value;
4033: }
1.311 albertel 4034: if (&untie_domain_hash($hashref)) {
1.238 foxr 4035: &Reply($client, "ok\n", $userinput);
4036: } else {
4037: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4038: "while attempting idput\n", $userinput);
4039: }
4040: } else {
4041: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
4042: "while attempting idput\n", $userinput);
4043: }
4044:
4045: return 1;
4046: }
1.263 albertel 4047: ®ister_handler("idput", \&put_id_handler, 0, 1, 0);
1.238 foxr 4048:
4049: #
4050: # Retrieves a set of id values from the id database.
4051: # Returns an & separated list of results, one for each requested id to the
4052: # client.
4053: #
4054: # Parameters:
4055: # $cmd - Command keyword that caused us to be dispatched.
4056: # $tail - Tail of the command. Consists of a colon separated:
4057: # domain - the domain whose id table we dump
4058: # ids Consists of an & separated list of
4059: # id keywords whose values will be fetched.
4060: # nonexisting keywords will have an empty value.
4061: # $client - Socket open on the client.
4062: #
4063: # Returns:
4064: # 1 - indicating processing should continue.
4065: # Side effects:
4066: # An & separated list of results is written to $client.
4067: #
4068: sub get_id_handler {
4069: my ($cmd, $tail, $client) = @_;
4070:
4071:
4072: my $userinput = "$client:$tail";
4073:
4074: my ($udom,$what)=split(/:/,$tail);
4075: chomp($what);
4076: my @queries=split(/\&/,$what);
4077: my $qresult='';
4078: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_READER());
4079: if ($hashref) {
4080: for (my $i=0;$i<=$#queries;$i++) {
4081: $qresult.="$hashref->{$queries[$i]}&";
4082: }
1.311 albertel 4083: if (&untie_domain_hash($hashref)) {
1.238 foxr 4084: $qresult=~s/\&$//;
1.387 albertel 4085: &Reply($client, \$qresult, $userinput);
1.238 foxr 4086: } else {
4087: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
4088: "while attempting idget\n",$userinput);
4089: }
4090: } else {
4091: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
4092: "while attempting idget\n",$userinput);
4093: }
4094:
4095: return 1;
4096: }
1.263 albertel 4097: ®ister_handler("idget", \&get_id_handler, 0, 1, 0);
1.238 foxr 4098:
4099: #
1.299 raeburn 4100: # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database
4101: #
4102: # Parameters
4103: # $cmd - Command keyword that caused us to be dispatched.
4104: # $tail - Tail of the command. Consists of a colon separated:
4105: # domain - the domain whose dcmail we are recording
4106: # email Consists of key=value pair
4107: # where key is unique msgid
4108: # and value is message (in XML)
4109: # $client - Socket open on the client.
4110: #
4111: # Returns:
4112: # 1 - indicating processing should continue.
4113: # Side effects
4114: # reply is written to $client.
4115: #
4116: sub put_dcmail_handler {
4117: my ($cmd,$tail,$client) = @_;
4118: my $userinput = "$cmd:$tail";
4119:
4120: my ($udom,$what)=split(/:/,$tail);
4121: chomp($what);
4122: my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
4123: if ($hashref) {
4124: my ($key,$value)=split(/=/,$what);
4125: $hashref->{$key}=$value;
4126: }
1.311 albertel 4127: if (&untie_domain_hash($hashref)) {
1.299 raeburn 4128: &Reply($client, "ok\n", $userinput);
4129: } else {
4130: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4131: "while attempting dcmailput\n", $userinput);
4132: }
4133: return 1;
4134: }
4135: ®ister_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0);
4136:
4137: #
4138: # Retrieves broadcast e-mail from nohist_dcmail database
4139: # Returns to client an & separated list of key=value pairs,
4140: # where key is msgid and value is message information.
4141: #
4142: # Parameters
4143: # $cmd - Command keyword that caused us to be dispatched.
4144: # $tail - Tail of the command. Consists of a colon separated:
4145: # domain - the domain whose dcmail table we dump
4146: # startfilter - beginning of time window
4147: # endfilter - end of time window
4148: # sendersfilter - & separated list of username:domain
4149: # for senders to search for.
4150: # $client - Socket open on the client.
4151: #
4152: # Returns:
4153: # 1 - indicating processing should continue.
4154: # Side effects
4155: # reply (& separated list of msgid=messageinfo pairs) is
4156: # written to $client.
4157: #
4158: sub dump_dcmail_handler {
4159: my ($cmd, $tail, $client) = @_;
4160:
4161: my $userinput = "$cmd:$tail";
4162: my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail);
4163: chomp($sendersfilter);
4164: my @senders = ();
4165: if (defined($startfilter)) {
4166: $startfilter=&unescape($startfilter);
4167: } else {
4168: $startfilter='.';
4169: }
4170: if (defined($endfilter)) {
4171: $endfilter=&unescape($endfilter);
4172: } else {
4173: $endfilter='.';
4174: }
4175: if (defined($sendersfilter)) {
4176: $sendersfilter=&unescape($sendersfilter);
1.300 albertel 4177: @senders = map { &unescape($_) } split(/\&/,$sendersfilter);
1.299 raeburn 4178: }
4179:
4180: my $qresult='';
4181: my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
4182: if ($hashref) {
4183: while (my ($key,$value) = each(%$hashref)) {
4184: my $match = 1;
1.303 albertel 4185: my ($timestamp,$subj,$uname,$udom) =
4186: split(/:/,&unescape(&unescape($key)),5); # yes, twice really
1.299 raeburn 4187: $subj = &unescape($subj);
4188: unless ($startfilter eq '.' || !defined($startfilter)) {
4189: if ($timestamp < $startfilter) {
4190: $match = 0;
4191: }
4192: }
4193: unless ($endfilter eq '.' || !defined($endfilter)) {
4194: if ($timestamp > $endfilter) {
4195: $match = 0;
4196: }
4197: }
4198: unless (@senders < 1) {
4199: unless (grep/^$uname:$udom$/,@senders) {
4200: $match = 0;
4201: }
4202: }
4203: if ($match == 1) {
4204: $qresult.=$key.'='.$value.'&';
4205: }
4206: }
1.311 albertel 4207: if (&untie_domain_hash($hashref)) {
1.299 raeburn 4208: chop($qresult);
1.387 albertel 4209: &Reply($client, \$qresult, $userinput);
1.299 raeburn 4210: } else {
4211: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4212: "while attempting dcmaildump\n", $userinput);
4213: }
4214: } else {
4215: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
4216: "while attempting dcmaildump\n", $userinput);
4217: }
4218: return 1;
4219: }
4220:
4221: ®ister_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0);
4222:
4223: #
4224: # Puts domain roles in nohist_domainroles database
4225: #
4226: # Parameters
4227: # $cmd - Command keyword that caused us to be dispatched.
4228: # $tail - Tail of the command. Consists of a colon separated:
4229: # domain - the domain whose roles we are recording
4230: # role - Consists of key=value pair
4231: # where key is unique role
4232: # and value is start/end date information
4233: # $client - Socket open on the client.
4234: #
4235: # Returns:
4236: # 1 - indicating processing should continue.
4237: # Side effects
4238: # reply is written to $client.
4239: #
4240:
4241: sub put_domainroles_handler {
4242: my ($cmd,$tail,$client) = @_;
4243:
4244: my $userinput = "$cmd:$tail";
4245: my ($udom,$what)=split(/:/,$tail);
4246: chomp($what);
4247: my @pairs=split(/\&/,$what);
4248: my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
4249: if ($hashref) {
4250: foreach my $pair (@pairs) {
4251: my ($key,$value)=split(/=/,$pair);
4252: $hashref->{$key}=$value;
4253: }
1.311 albertel 4254: if (&untie_domain_hash($hashref)) {
1.299 raeburn 4255: &Reply($client, "ok\n", $userinput);
4256: } else {
4257: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4258: "while attempting domroleput\n", $userinput);
4259: }
4260: } else {
4261: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
4262: "while attempting domroleput\n", $userinput);
4263: }
4264:
4265: return 1;
4266: }
4267:
4268: ®ister_handler("domroleput", \&put_domainroles_handler, 0, 1, 0);
4269:
4270: #
4271: # Retrieves domain roles from nohist_domainroles database
4272: # Returns to client an & separated list of key=value pairs,
4273: # where key is role and value is start and end date information.
4274: #
4275: # Parameters
4276: # $cmd - Command keyword that caused us to be dispatched.
4277: # $tail - Tail of the command. Consists of a colon separated:
4278: # domain - the domain whose domain roles table we dump
4279: # $client - Socket open on the client.
4280: #
4281: # Returns:
4282: # 1 - indicating processing should continue.
4283: # Side effects
4284: # reply (& separated list of role=start/end info pairs) is
4285: # written to $client.
4286: #
4287: sub dump_domainroles_handler {
4288: my ($cmd, $tail, $client) = @_;
4289:
4290: my $userinput = "$cmd:$tail";
4291: my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail);
4292: chomp($rolesfilter);
4293: my @roles = ();
4294: if (defined($startfilter)) {
4295: $startfilter=&unescape($startfilter);
4296: } else {
4297: $startfilter='.';
4298: }
4299: if (defined($endfilter)) {
4300: $endfilter=&unescape($endfilter);
4301: } else {
4302: $endfilter='.';
4303: }
4304: if (defined($rolesfilter)) {
4305: $rolesfilter=&unescape($rolesfilter);
1.300 albertel 4306: @roles = split(/\&/,$rolesfilter);
1.299 raeburn 4307: }
4308:
4309: my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
4310: if ($hashref) {
4311: my $qresult = '';
4312: while (my ($key,$value) = each(%$hashref)) {
4313: my $match = 1;
4314: my ($start,$end) = split(/:/,&unescape($value));
4315: my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
4316: unless ($startfilter eq '.' || !defined($startfilter)) {
4317: if ($start >= $startfilter) {
4318: $match = 0;
4319: }
4320: }
4321: unless ($endfilter eq '.' || !defined($endfilter)) {
4322: if ($end <= $endfilter) {
4323: $match = 0;
4324: }
4325: }
4326: unless (@roles < 1) {
1.389 raeburn 4327: unless (grep/^\Q$trole\E$/,@roles) {
1.299 raeburn 4328: $match = 0;
4329: }
4330: }
4331: if ($match == 1) {
4332: $qresult.=$key.'='.$value.'&';
4333: }
4334: }
1.311 albertel 4335: if (&untie_domain_hash($hashref)) {
1.299 raeburn 4336: chop($qresult);
1.387 albertel 4337: &Reply($client, \$qresult, $userinput);
1.299 raeburn 4338: } else {
4339: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4340: "while attempting domrolesdump\n", $userinput);
4341: }
4342: } else {
4343: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
4344: "while attempting domrolesdump\n", $userinput);
4345: }
4346: return 1;
4347: }
4348:
4349: ®ister_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0);
4350:
4351:
1.238 foxr 4352: # Process the tmpput command I'm not sure what this does.. Seems to
4353: # create a file in the lonDaemons/tmp directory of the form $id.tmp
4354: # where Id is the client's ip concatenated with a sequence number.
4355: # The file will contain some value that is passed in. Is this e.g.
4356: # a login token?
4357: #
4358: # Parameters:
4359: # $cmd - The command that got us dispatched.
4360: # $tail - The remainder of the request following $cmd:
4361: # In this case this will be the contents of the file.
4362: # $client - Socket connected to the client.
4363: # Returns:
4364: # 1 indicating processing can continue.
4365: # Side effects:
4366: # A file is created in the local filesystem.
4367: # A reply is sent to the client.
4368: sub tmp_put_handler {
4369: my ($cmd, $what, $client) = @_;
4370:
4371: my $userinput = "$cmd:$what"; # Reconstruct for logging.
4372:
1.347 raeburn 4373: my ($record,$context) = split(/:/,$what);
4374: if ($context ne '') {
4375: chomp($context);
4376: $context = &unescape($context);
4377: }
4378: my ($id,$store);
1.238 foxr 4379: $tmpsnum++;
1.347 raeburn 4380: if ($context eq 'resetpw') {
4381: $id = &md5_hex(&md5_hex(time.{}.rand().$$));
4382: } else {
4383: $id = $$.'_'.$clientip.'_'.$tmpsnum;
4384: }
1.238 foxr 4385: $id=~s/\W/\_/g;
1.347 raeburn 4386: $record=~s/\n//g;
1.238 foxr 4387: my $execdir=$perlvar{'lonDaemons'};
4388: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
1.347 raeburn 4389: print $store $record;
1.238 foxr 4390: close $store;
1.387 albertel 4391: &Reply($client, \$id, $userinput);
1.238 foxr 4392: } else {
4393: &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
4394: "while attempting tmpput\n", $userinput);
4395: }
4396: return 1;
4397:
4398: }
4399: ®ister_handler("tmpput", \&tmp_put_handler, 0, 1, 0);
1.263 albertel 4400:
1.238 foxr 4401: # Processes the tmpget command. This command returns the contents
4402: # of a temporary resource file(?) created via tmpput.
4403: #
4404: # Paramters:
4405: # $cmd - Command that got us dispatched.
4406: # $id - Tail of the command, contain the id of the resource
4407: # we want to fetch.
4408: # $client - socket open on the client.
4409: # Return:
4410: # 1 - Inidcating processing can continue.
4411: # Side effects:
4412: # A reply is sent to the client.
4413: #
4414: sub tmp_get_handler {
4415: my ($cmd, $id, $client) = @_;
4416:
4417: my $userinput = "$cmd:$id";
4418:
4419:
4420: $id=~s/\W/\_/g;
4421: my $store;
4422: my $execdir=$perlvar{'lonDaemons'};
4423: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
4424: my $reply=<$store>;
1.387 albertel 4425: &Reply( $client, \$reply, $userinput);
1.238 foxr 4426: close $store;
4427: } else {
4428: &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
4429: "while attempting tmpget\n", $userinput);
4430: }
4431:
4432: return 1;
4433: }
4434: ®ister_handler("tmpget", \&tmp_get_handler, 0, 1, 0);
1.263 albertel 4435:
1.238 foxr 4436: #
4437: # Process the tmpdel command. This command deletes a temp resource
4438: # created by the tmpput command.
4439: #
4440: # Parameters:
4441: # $cmd - Command that got us here.
4442: # $id - Id of the temporary resource created.
4443: # $client - socket open on the client process.
4444: #
4445: # Returns:
4446: # 1 - Indicating processing should continue.
4447: # Side Effects:
4448: # A file is deleted
4449: # A reply is sent to the client.
4450: sub tmp_del_handler {
4451: my ($cmd, $id, $client) = @_;
4452:
4453: my $userinput= "$cmd:$id";
4454:
4455: chomp($id);
4456: $id=~s/\W/\_/g;
4457: my $execdir=$perlvar{'lonDaemons'};
4458: if (unlink("$execdir/tmp/$id.tmp")) {
4459: &Reply($client, "ok\n", $userinput);
4460: } else {
4461: &Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".
4462: "while attempting tmpdel\n", $userinput);
4463: }
4464:
4465: return 1;
4466:
4467: }
4468: ®ister_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);
1.263 albertel 4469:
1.238 foxr 4470: #
1.246 foxr 4471: # Processes the setannounce command. This command
4472: # creates a file named announce.txt in the top directory of
4473: # the documentn root and sets its contents. The announce.txt file is
4474: # printed in its entirety at the LonCAPA login page. Note:
4475: # once the announcement.txt fileis created it cannot be deleted.
4476: # However, setting the contents of the file to empty removes the
4477: # announcement from the login page of loncapa so who cares.
4478: #
4479: # Parameters:
4480: # $cmd - The command that got us dispatched.
4481: # $announcement - The text of the announcement.
4482: # $client - Socket open on the client process.
4483: # Retunrns:
4484: # 1 - Indicating request processing should continue
4485: # Side Effects:
4486: # The file {DocRoot}/announcement.txt is created.
4487: # A reply is sent to $client.
4488: #
4489: sub set_announce_handler {
4490: my ($cmd, $announcement, $client) = @_;
4491:
4492: my $userinput = "$cmd:$announcement";
4493:
4494: chomp($announcement);
4495: $announcement=&unescape($announcement);
4496: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
4497: '/announcement.txt')) {
4498: print $store $announcement;
4499: close $store;
4500: &Reply($client, "ok\n", $userinput);
4501: } else {
4502: &Failure($client, "error: ".($!+0)."\n", $userinput);
4503: }
4504:
4505: return 1;
4506: }
4507: ®ister_handler("setannounce", \&set_announce_handler, 0, 1, 0);
1.263 albertel 4508:
1.246 foxr 4509: #
4510: # Return the version of the daemon. This can be used to determine
4511: # the compatibility of cross version installations or, alternatively to
4512: # simply know who's out of date and who isn't. Note that the version
4513: # is returned concatenated with the tail.
4514: # Parameters:
4515: # $cmd - the request that dispatched to us.
4516: # $tail - Tail of the request (client's version?).
4517: # $client - Socket open on the client.
4518: #Returns:
4519: # 1 - continue processing requests.
4520: # Side Effects:
4521: # Replies with version to $client.
4522: sub get_version_handler {
4523: my ($cmd, $tail, $client) = @_;
4524:
4525: my $userinput = $cmd.$tail;
4526:
4527: &Reply($client, &version($userinput)."\n", $userinput);
4528:
4529:
4530: return 1;
4531: }
4532: ®ister_handler("version", \&get_version_handler, 0, 1, 0);
1.263 albertel 4533:
1.246 foxr 4534: # Set the current host and domain. This is used to support
4535: # multihomed systems. Each IP of the system, or even separate daemons
4536: # on the same IP can be treated as handling a separate lonCAPA virtual
4537: # machine. This command selects the virtual lonCAPA. The client always
4538: # knows the right one since it is lonc and it is selecting the domain/system
4539: # from the hosts.tab file.
4540: # Parameters:
4541: # $cmd - Command that dispatched us.
4542: # $tail - Tail of the command (domain/host requested).
4543: # $socket - Socket open on the client.
4544: #
4545: # Returns:
4546: # 1 - Indicates the program should continue to process requests.
4547: # Side-effects:
4548: # The default domain/system context is modified for this daemon.
4549: # a reply is sent to the client.
4550: #
4551: sub set_virtual_host_handler {
4552: my ($cmd, $tail, $socket) = @_;
4553:
4554: my $userinput ="$cmd:$tail";
4555:
4556: &Reply($client, &sethost($userinput)."\n", $userinput);
4557:
4558:
4559: return 1;
4560: }
1.247 albertel 4561: ®ister_handler("sethost", \&set_virtual_host_handler, 0, 1, 0);
1.246 foxr 4562:
4563: # Process a request to exit:
4564: # - "bye" is sent to the client.
4565: # - The client socket is shutdown and closed.
4566: # - We indicate to the caller that we should exit.
4567: # Formal Parameters:
4568: # $cmd - The command that got us here.
4569: # $tail - Tail of the command (empty).
4570: # $client - Socket open on the tail.
4571: # Returns:
4572: # 0 - Indicating the program should exit!!
4573: #
4574: sub exit_handler {
4575: my ($cmd, $tail, $client) = @_;
4576:
4577: my $userinput = "$cmd:$tail";
4578:
4579: &logthis("Client $clientip ($clientname) hanging up: $userinput");
4580: &Reply($client, "bye\n", $userinput);
4581: $client->shutdown(2); # shutdown the socket forcibly.
4582: $client->close();
4583:
4584: return 0;
4585: }
1.248 foxr 4586: ®ister_handler("exit", \&exit_handler, 0,1,1);
4587: ®ister_handler("init", \&exit_handler, 0,1,1);
4588: ®ister_handler("quit", \&exit_handler, 0,1,1);
4589:
4590: # Determine if auto-enrollment is enabled.
4591: # Note that the original had what I believe to be a defect.
4592: # The original returned 0 if the requestor was not a registerd client.
4593: # It should return "refused".
4594: # Formal Parameters:
4595: # $cmd - The command that invoked us.
4596: # $tail - The tail of the command (Extra command parameters.
4597: # $client - The socket open on the client that issued the request.
4598: # Returns:
4599: # 1 - Indicating processing should continue.
4600: #
4601: sub enrollment_enabled_handler {
4602: my ($cmd, $tail, $client) = @_;
4603: my $userinput = $cmd.":".$tail; # For logging purposes.
4604:
4605:
1.337 albertel 4606: my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about.
4607:
1.248 foxr 4608: my $outcome = &localenroll::run($cdom);
1.387 albertel 4609: &Reply($client, \$outcome, $userinput);
1.248 foxr 4610:
4611: return 1;
4612: }
4613: ®ister_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
4614:
4615: # Get the official sections for which auto-enrollment is possible.
4616: # Since the admin people won't know about 'unofficial sections'
4617: # we cannot auto-enroll on them.
4618: # Formal Parameters:
4619: # $cmd - The command request that got us dispatched here.
4620: # $tail - The remainder of the request. In our case this
4621: # will be split into:
4622: # $coursecode - The course name from the admin point of view.
4623: # $cdom - The course's domain(?).
4624: # $client - Socket open on the client.
4625: # Returns:
4626: # 1 - Indiciting processing should continue.
4627: #
4628: sub get_sections_handler {
4629: my ($cmd, $tail, $client) = @_;
4630: my $userinput = "$cmd:$tail";
4631:
4632: my ($coursecode, $cdom) = split(/:/, $tail);
4633: my @secs = &localenroll::get_sections($coursecode,$cdom);
4634: my $seclist = &escape(join(':',@secs));
4635:
1.387 albertel 4636: &Reply($client, \$seclist, $userinput);
1.248 foxr 4637:
4638:
4639: return 1;
4640: }
4641: ®ister_handler("autogetsections", \&get_sections_handler, 0, 1, 0);
4642:
4643: # Validate the owner of a new course section.
4644: #
4645: # Formal Parameters:
4646: # $cmd - Command that got us dispatched.
4647: # $tail - the remainder of the command. For us this consists of a
4648: # colon separated string containing:
4649: # $inst - Course Id from the institutions point of view.
4650: # $owner - Proposed owner of the course.
4651: # $cdom - Domain of the course (from the institutions
4652: # point of view?)..
4653: # $client - Socket open on the client.
4654: #
4655: # Returns:
4656: # 1 - Processing should continue.
4657: #
4658: sub validate_course_owner_handler {
4659: my ($cmd, $tail, $client) = @_;
4660: my $userinput = "$cmd:$tail";
4661: my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
4662:
1.336 raeburn 4663: $owner = &unescape($owner);
1.248 foxr 4664: my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
1.387 albertel 4665: &Reply($client, \$outcome, $userinput);
1.248 foxr 4666:
4667:
4668:
4669: return 1;
4670: }
4671: ®ister_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);
1.263 albertel 4672:
1.248 foxr 4673: #
4674: # Validate a course section in the official schedule of classes
4675: # from the institutions point of view (part of autoenrollment).
4676: #
4677: # Formal Parameters:
4678: # $cmd - The command request that got us dispatched.
4679: # $tail - The tail of the command. In this case,
4680: # this is a colon separated set of words that will be split
4681: # into:
4682: # $inst_course_id - The course/section id from the
4683: # institutions point of view.
4684: # $cdom - The domain from the institutions
4685: # point of view.
4686: # $client - Socket open on the client.
4687: # Returns:
4688: # 1 - Indicating processing should continue.
4689: #
4690: sub validate_course_section_handler {
4691: my ($cmd, $tail, $client) = @_;
4692: my $userinput = "$cmd:$tail";
4693: my ($inst_course_id, $cdom) = split(/:/, $tail);
4694:
4695: my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
1.387 albertel 4696: &Reply($client, \$outcome, $userinput);
1.248 foxr 4697:
4698:
4699: return 1;
4700: }
4701: ®ister_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);
4702:
4703: #
1.340 raeburn 4704: # Validate course owner's access to enrollment data for specific class section.
4705: #
4706: #
4707: # Formal Parameters:
4708: # $cmd - The command request that got us dispatched.
4709: # $tail - The tail of the command. In this case this is a colon separated
4710: # set of words that will be split into:
4711: # $inst_class - Institutional code for the specific class section
4712: # $courseowner - The escaped username:domain of the course owner
4713: # $cdom - The domain of the course from the institution's
4714: # point of view.
4715: # $client - The socket open on the client.
4716: # Returns:
4717: # 1 - continue processing.
4718: #
4719:
4720: sub validate_class_access_handler {
4721: my ($cmd, $tail, $client) = @_;
4722: my $userinput = "$cmd:$tail";
1.383 raeburn 4723: my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail);
1.392 raeburn 4724: my $owners = &unescape($ownerlist);
1.341 albertel 4725: my $outcome;
4726: eval {
4727: local($SIG{__DIE__})='DEFAULT';
1.392 raeburn 4728: $outcome=&localenroll::check_section($inst_class,$owners,$cdom);
1.341 albertel 4729: };
1.387 albertel 4730: &Reply($client,\$outcome, $userinput);
1.340 raeburn 4731:
4732: return 1;
4733: }
4734: ®ister_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);
4735:
4736: #
4737: # Create a password for a new LON-CAPA user added by auto-enrollment.
4738: # Only used for case where authentication method for new user is localauth
1.248 foxr 4739: #
4740: # Formal Parameters:
4741: # $cmd - The command request that got us dispatched.
4742: # $tail - The tail of the command. In this case this is a colon separated
4743: # set of words that will be split into:
1.340 raeburn 4744: # $authparam - An authentication parameter (localauth parameter).
1.248 foxr 4745: # $cdom - The domain of the course from the institution's
4746: # point of view.
4747: # $client - The socket open on the client.
4748: # Returns:
4749: # 1 - continue processing.
4750: #
4751: sub create_auto_enroll_password_handler {
4752: my ($cmd, $tail, $client) = @_;
4753: my $userinput = "$cmd:$tail";
4754:
4755: my ($authparam, $cdom) = split(/:/, $userinput);
4756:
4757: my ($create_passwd,$authchk);
4758: ($authparam,
4759: $create_passwd,
4760: $authchk) = &localenroll::create_password($authparam,$cdom);
4761:
4762: &Reply($client, &escape($authparam.':'.$create_passwd.':'.$authchk)."\n",
4763: $userinput);
4764:
4765:
4766: return 1;
4767: }
4768: ®ister_handler("autocreatepassword", \&create_auto_enroll_password_handler,
4769: 0, 1, 0);
4770:
4771: # Retrieve and remove temporary files created by/during autoenrollment.
4772: #
4773: # Formal Parameters:
4774: # $cmd - The command that got us dispatched.
4775: # $tail - The tail of the command. In our case this is a colon
4776: # separated list that will be split into:
4777: # $filename - The name of the file to remove.
4778: # The filename is given as a path relative to
4779: # the LonCAPA temp file directory.
4780: # $client - Socket open on the client.
4781: #
4782: # Returns:
4783: # 1 - Continue processing.
4784: sub retrieve_auto_file_handler {
4785: my ($cmd, $tail, $client) = @_;
4786: my $userinput = "cmd:$tail";
4787:
4788: my ($filename) = split(/:/, $tail);
4789:
4790: my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
4791: if ( (-e $source) && ($filename ne '') ) {
4792: my $reply = '';
4793: if (open(my $fh,$source)) {
4794: while (<$fh>) {
4795: chomp($_);
4796: $_ =~ s/^\s+//g;
4797: $_ =~ s/\s+$//g;
4798: $reply .= $_;
4799: }
4800: close($fh);
4801: &Reply($client, &escape($reply)."\n", $userinput);
4802:
4803: # Does this have to be uncommented??!? (RF).
4804: #
4805: # unlink($source);
4806: } else {
4807: &Failure($client, "error\n", $userinput);
4808: }
4809: } else {
4810: &Failure($client, "error\n", $userinput);
4811: }
4812:
4813:
4814: return 1;
4815: }
4816: ®ister_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);
4817:
4818: #
4819: # Read and retrieve institutional code format (for support form).
4820: # Formal Parameters:
4821: # $cmd - Command that dispatched us.
4822: # $tail - Tail of the command. In this case it conatins
4823: # the course domain and the coursename.
4824: # $client - Socket open on the client.
4825: # Returns:
4826: # 1 - Continue processing.
4827: #
4828: sub get_institutional_code_format_handler {
4829: my ($cmd, $tail, $client) = @_;
4830: my $userinput = "$cmd:$tail";
4831:
4832: my $reply;
4833: my($cdom,$course) = split(/:/,$tail);
4834: my @pairs = split/\&/,$course;
4835: my %instcodes = ();
4836: my %codes = ();
4837: my @codetitles = ();
4838: my %cat_titles = ();
4839: my %cat_order = ();
4840: foreach (@pairs) {
4841: my ($key,$value) = split/=/,$_;
4842: $instcodes{&unescape($key)} = &unescape($value);
4843: }
4844: my $formatreply = &localenroll::instcode_format($cdom,
4845: \%instcodes,
4846: \%codes,
4847: \@codetitles,
4848: \%cat_titles,
4849: \%cat_order);
4850: if ($formatreply eq 'ok') {
1.365 albertel 4851: my $codes_str = &Apache::lonnet::hash2str(%codes);
4852: my $codetitles_str = &Apache::lonnet::array2str(@codetitles);
4853: my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles);
4854: my $cat_order_str = &Apache::lonnet::hash2str(%cat_order);
1.248 foxr 4855: &Reply($client,
4856: $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
4857: .$cat_order_str."\n",
4858: $userinput);
4859: } else {
4860: # this else branch added by RF since if not ok, lonc will
4861: # hang waiting on reply until timeout.
4862: #
4863: &Reply($client, "format_error\n", $userinput);
4864: }
4865:
4866: return 1;
4867: }
1.265 albertel 4868: ®ister_handler("autoinstcodeformat",
4869: \&get_institutional_code_format_handler,0,1,0);
1.246 foxr 4870:
1.345 raeburn 4871: sub get_institutional_defaults_handler {
4872: my ($cmd, $tail, $client) = @_;
4873: my $userinput = "$cmd:$tail";
4874:
4875: my $dom = $tail;
4876: my %defaults_hash;
4877: my @code_order;
4878: my $outcome;
4879: eval {
4880: local($SIG{__DIE__})='DEFAULT';
4881: $outcome = &localenroll::instcode_defaults($dom,\%defaults_hash,
4882: \@code_order);
4883: };
4884: if (!$@) {
4885: if ($outcome eq 'ok') {
4886: my $result='';
4887: while (my ($key,$value) = each(%defaults_hash)) {
4888: $result.=&escape($key).'='.&escape($value).'&';
4889: }
4890: $result .= 'code_order='.&escape(join('&',@code_order));
1.387 albertel 4891: &Reply($client,\$result,$userinput);
1.345 raeburn 4892: } else {
4893: &Reply($client,"error\n", $userinput);
4894: }
4895: } else {
4896: &Failure($client,"unknown_cmd\n",$userinput);
4897: }
4898: }
4899: ®ister_handler("autoinstcodedefaults",
4900: \&get_institutional_defaults_handler,0,1,0);
4901:
1.381 raeburn 4902: sub get_institutional_user_rules {
4903: my ($cmd, $tail, $client) = @_;
4904: my $userinput = "$cmd:$tail";
4905: my $dom = &unescape($tail);
4906: my (%rules_hash,@rules_order);
4907: my $outcome;
4908: eval {
4909: local($SIG{__DIE__})='DEFAULT';
4910: $outcome = &localenroll::username_rules($dom,\%rules_hash,\@rules_order);
4911: };
4912: if (!$@) {
4913: if ($outcome eq 'ok') {
4914: my $result;
4915: foreach my $key (keys(%rules_hash)) {
4916: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
4917: }
4918: $result =~ s/\&$//;
4919: $result .= ':';
4920: if (@rules_order > 0) {
4921: foreach my $item (@rules_order) {
4922: $result .= &escape($item).'&';
4923: }
4924: }
4925: $result =~ s/\&$//;
1.387 albertel 4926: &Reply($client,\$result,$userinput);
1.381 raeburn 4927: } else {
4928: &Reply($client,"error\n", $userinput);
4929: }
4930: } else {
4931: &Failure($client,"unknown_cmd\n",$userinput);
4932: }
4933: }
4934: ®ister_handler("instuserrules",\&get_institutional_user_rules,0,1,0);
4935:
1.389 raeburn 4936: sub get_institutional_id_rules {
4937: my ($cmd, $tail, $client) = @_;
4938: my $userinput = "$cmd:$tail";
4939: my $dom = &unescape($tail);
4940: my (%rules_hash,@rules_order);
4941: my $outcome;
4942: eval {
4943: local($SIG{__DIE__})='DEFAULT';
4944: $outcome = &localenroll::id_rules($dom,\%rules_hash,\@rules_order);
4945: };
4946: if (!$@) {
4947: if ($outcome eq 'ok') {
4948: my $result;
4949: foreach my $key (keys(%rules_hash)) {
4950: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
4951: }
4952: $result =~ s/\&$//;
4953: $result .= ':';
4954: if (@rules_order > 0) {
4955: foreach my $item (@rules_order) {
4956: $result .= &escape($item).'&';
4957: }
4958: }
4959: $result =~ s/\&$//;
4960: &Reply($client,\$result,$userinput);
4961: } else {
4962: &Reply($client,"error\n", $userinput);
4963: }
4964: } else {
4965: &Failure($client,"unknown_cmd\n",$userinput);
4966: }
4967: }
4968: ®ister_handler("instidrules",\&get_institutional_id_rules,0,1,0);
4969:
1.397 raeburn 4970: sub get_institutional_selfcreate_rules {
1.396 raeburn 4971: my ($cmd, $tail, $client) = @_;
4972: my $userinput = "$cmd:$tail";
4973: my $dom = &unescape($tail);
4974: my (%rules_hash,@rules_order);
4975: my $outcome;
4976: eval {
4977: local($SIG{__DIE__})='DEFAULT';
1.397 raeburn 4978: $outcome = &localenroll::selfcreate_rules($dom,\%rules_hash,\@rules_order);
1.396 raeburn 4979: };
4980: if (!$@) {
4981: if ($outcome eq 'ok') {
4982: my $result;
4983: foreach my $key (keys(%rules_hash)) {
4984: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
4985: }
4986: $result =~ s/\&$//;
4987: $result .= ':';
4988: if (@rules_order > 0) {
4989: foreach my $item (@rules_order) {
4990: $result .= &escape($item).'&';
4991: }
4992: }
4993: $result =~ s/\&$//;
4994: &Reply($client,\$result,$userinput);
4995: } else {
4996: &Reply($client,"error\n", $userinput);
4997: }
4998: } else {
4999: &Failure($client,"unknown_cmd\n",$userinput);
5000: }
5001: }
1.397 raeburn 5002: ®ister_handler("instemailrules",\&get_institutional_selfcreate_rules,0,1,0);
1.396 raeburn 5003:
1.381 raeburn 5004:
5005: sub institutional_username_check {
5006: my ($cmd, $tail, $client) = @_;
5007: my $userinput = "$cmd:$tail";
5008: my %rulecheck;
5009: my $outcome;
5010: my ($udom,$uname,@rules) = split(/:/,$tail);
5011: $udom = &unescape($udom);
5012: $uname = &unescape($uname);
5013: @rules = map {&unescape($_);} (@rules);
5014: eval {
5015: local($SIG{__DIE__})='DEFAULT';
5016: $outcome = &localenroll::username_check($udom,$uname,\@rules,\%rulecheck);
5017: };
5018: if (!$@) {
5019: if ($outcome eq 'ok') {
5020: my $result='';
5021: foreach my $key (keys(%rulecheck)) {
5022: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
5023: }
1.387 albertel 5024: &Reply($client,\$result,$userinput);
1.381 raeburn 5025: } else {
5026: &Reply($client,"error\n", $userinput);
5027: }
5028: } else {
5029: &Failure($client,"unknown_cmd\n",$userinput);
5030: }
5031: }
5032: ®ister_handler("instrulecheck",\&institutional_username_check,0,1,0);
5033:
1.389 raeburn 5034: sub institutional_id_check {
5035: my ($cmd, $tail, $client) = @_;
5036: my $userinput = "$cmd:$tail";
5037: my %rulecheck;
5038: my $outcome;
5039: my ($udom,$id,@rules) = split(/:/,$tail);
5040: $udom = &unescape($udom);
5041: $id = &unescape($id);
5042: @rules = map {&unescape($_);} (@rules);
5043: eval {
5044: local($SIG{__DIE__})='DEFAULT';
5045: $outcome = &localenroll::id_check($udom,$id,\@rules,\%rulecheck);
5046: };
5047: if (!$@) {
5048: if ($outcome eq 'ok') {
5049: my $result='';
5050: foreach my $key (keys(%rulecheck)) {
5051: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
5052: }
5053: &Reply($client,\$result,$userinput);
5054: } else {
5055: &Reply($client,"error\n", $userinput);
5056: }
5057: } else {
5058: &Failure($client,"unknown_cmd\n",$userinput);
5059: }
5060: }
5061: ®ister_handler("instidrulecheck",\&institutional_id_check,0,1,0);
1.345 raeburn 5062:
1.397 raeburn 5063: sub institutional_selfcreate_check {
1.396 raeburn 5064: my ($cmd, $tail, $client) = @_;
5065: my $userinput = "$cmd:$tail";
5066: my %rulecheck;
5067: my $outcome;
5068: my ($udom,$email,@rules) = split(/:/,$tail);
5069: $udom = &unescape($udom);
5070: $email = &unescape($email);
5071: @rules = map {&unescape($_);} (@rules);
5072: eval {
5073: local($SIG{__DIE__})='DEFAULT';
1.397 raeburn 5074: $outcome = &localenroll::selfcreate_check($udom,$email,\@rules,\%rulecheck);
1.396 raeburn 5075: };
5076: if (!$@) {
5077: if ($outcome eq 'ok') {
5078: my $result='';
5079: foreach my $key (keys(%rulecheck)) {
5080: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
5081: }
5082: &Reply($client,\$result,$userinput);
5083: } else {
5084: &Reply($client,"error\n", $userinput);
5085: }
5086: } else {
5087: &Failure($client,"unknown_cmd\n",$userinput);
5088: }
5089: }
1.397 raeburn 5090: ®ister_handler("instselfcreatecheck",\&institutional_selfcreate_check,0,1,0);
1.396 raeburn 5091:
1.317 raeburn 5092: # Get domain specific conditions for import of student photographs to a course
5093: #
5094: # Retrieves information from photo_permission subroutine in localenroll.
5095: # Returns outcome (ok) if no processing errors, and whether course owner is
5096: # required to accept conditions of use (yes/no).
5097: #
5098: #
5099: sub photo_permission_handler {
5100: my ($cmd, $tail, $client) = @_;
5101: my $userinput = "$cmd:$tail";
5102: my $cdom = $tail;
5103: my ($perm_reqd,$conditions);
1.320 albertel 5104: my $outcome;
5105: eval {
5106: local($SIG{__DIE__})='DEFAULT';
5107: $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
5108: \$conditions);
5109: };
5110: if (!$@) {
5111: &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
5112: $userinput);
5113: } else {
5114: &Failure($client,"unknown_cmd\n",$userinput);
5115: }
5116: return 1;
1.317 raeburn 5117: }
5118: ®ister_handler("autophotopermission",\&photo_permission_handler,0,1,0);
5119:
5120: #
5121: # Checks if student photo is available for a user in the domain, in the user's
5122: # directory (in /userfiles/internal/studentphoto.jpg).
5123: # Uses localstudentphoto:fetch() to ensure there is an up to date copy of
5124: # the student's photo.
5125:
5126: sub photo_check_handler {
5127: my ($cmd, $tail, $client) = @_;
5128: my $userinput = "$cmd:$tail";
5129: my ($udom,$uname,$pid) = split(/:/,$tail);
5130: $udom = &unescape($udom);
5131: $uname = &unescape($uname);
5132: $pid = &unescape($pid);
5133: my $path=&propath($udom,$uname).'/userfiles/internal/';
5134: if (!-e $path) {
5135: &mkpath($path);
5136: }
5137: my $response;
5138: my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
5139: $result .= ':'.$response;
5140: &Reply($client, &escape($result)."\n",$userinput);
1.320 albertel 5141: return 1;
1.317 raeburn 5142: }
5143: ®ister_handler("autophotocheck",\&photo_check_handler,0,1,0);
5144:
5145: #
5146: # Retrieve information from localenroll about whether to provide a button
5147: # for users who have enbled import of student photos to initiate an
5148: # update of photo files for registered students. Also include
5149: # comment to display alongside button.
5150:
5151: sub photo_choice_handler {
5152: my ($cmd, $tail, $client) = @_;
5153: my $userinput = "$cmd:$tail";
5154: my $cdom = &unescape($tail);
1.320 albertel 5155: my ($update,$comment);
5156: eval {
5157: local($SIG{__DIE__})='DEFAULT';
5158: ($update,$comment) = &localenroll::manager_photo_update($cdom);
5159: };
5160: if (!$@) {
5161: &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
5162: } else {
5163: &Failure($client,"unknown_cmd\n",$userinput);
5164: }
5165: return 1;
1.317 raeburn 5166: }
5167: ®ister_handler("autophotochoice",\&photo_choice_handler,0,1,0);
5168:
1.265 albertel 5169: #
5170: # Gets a student's photo to exist (in the correct image type) in the user's
5171: # directory.
5172: # Formal Parameters:
5173: # $cmd - The command request that got us dispatched.
5174: # $tail - A colon separated set of words that will be split into:
5175: # $domain - student's domain
5176: # $uname - student username
5177: # $type - image type desired
5178: # $client - The socket open on the client.
5179: # Returns:
5180: # 1 - continue processing.
1.317 raeburn 5181:
1.265 albertel 5182: sub student_photo_handler {
5183: my ($cmd, $tail, $client) = @_;
1.317 raeburn 5184: my ($domain,$uname,$ext,$type) = split(/:/, $tail);
1.265 albertel 5185:
1.317 raeburn 5186: my $path=&propath($domain,$uname). '/userfiles/internal/';
5187: my $filename = 'studentphoto.'.$ext;
5188: if ($type eq 'thumbnail') {
5189: $filename = 'studentphoto_tn.'.$ext;
5190: }
5191: if (-e $path.$filename) {
1.265 albertel 5192: &Reply($client,"ok\n","$cmd:$tail");
5193: return 1;
5194: }
5195: &mkpath($path);
1.317 raeburn 5196: my $file;
5197: if ($type eq 'thumbnail') {
1.320 albertel 5198: eval {
5199: local($SIG{__DIE__})='DEFAULT';
5200: $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
5201: };
1.317 raeburn 5202: } else {
5203: $file=&localstudentphoto::fetch($domain,$uname);
5204: }
1.265 albertel 5205: if (!$file) {
5206: &Failure($client,"unavailable\n","$cmd:$tail");
5207: return 1;
5208: }
1.317 raeburn 5209: if (!-e $path.$filename) { &convert_photo($file,$path.$filename); }
5210: if (-e $path.$filename) {
1.265 albertel 5211: &Reply($client,"ok\n","$cmd:$tail");
5212: return 1;
5213: }
5214: &Failure($client,"unable_to_convert\n","$cmd:$tail");
5215: return 1;
5216: }
5217: ®ister_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
1.246 foxr 5218:
1.361 raeburn 5219: sub inst_usertypes_handler {
5220: my ($cmd, $domain, $client) = @_;
5221: my $res;
5222: my $userinput = $cmd.":".$domain; # For logging purposes.
1.370 albertel 5223: my (%typeshash,@order,$result);
5224: eval {
5225: local($SIG{__DIE__})='DEFAULT';
5226: $result=&localenroll::inst_usertypes($domain,\%typeshash,\@order);
5227: };
5228: if ($result eq 'ok') {
1.361 raeburn 5229: if (keys(%typeshash) > 0) {
5230: foreach my $key (keys(%typeshash)) {
5231: $res.=&escape($key).'='.&escape($typeshash{$key}).'&';
5232: }
5233: }
5234: $res=~s/\&$//;
5235: $res .= ':';
5236: if (@order > 0) {
5237: foreach my $item (@order) {
5238: $res .= &escape($item).'&';
5239: }
5240: }
5241: $res=~s/\&$//;
5242: }
1.387 albertel 5243: &Reply($client, \$res, $userinput);
1.361 raeburn 5244: return 1;
5245: }
5246: ®ister_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);
5247:
1.264 albertel 5248: # mkpath makes all directories for a file, expects an absolute path with a
5249: # file or a trailing / if just a dir is passed
5250: # returns 1 on success 0 on failure
5251: sub mkpath {
5252: my ($file)=@_;
5253: my @parts=split(/\//,$file,-1);
5254: my $now=$parts[0].'/'.$parts[1].'/'.$parts[2];
5255: for (my $i=3;$i<= ($#parts-1);$i++) {
1.265 albertel 5256: $now.='/'.$parts[$i];
1.264 albertel 5257: if (!-e $now) {
5258: if (!mkdir($now,0770)) { return 0; }
5259: }
5260: }
5261: return 1;
5262: }
5263:
1.207 foxr 5264: #---------------------------------------------------------------
5265: #
5266: # Getting, decoding and dispatching requests:
5267: #
5268: #
5269: # Get a Request:
5270: # Gets a Request message from the client. The transaction
5271: # is defined as a 'line' of text. We remove the new line
5272: # from the text line.
1.226 foxr 5273: #
1.211 albertel 5274: sub get_request {
1.207 foxr 5275: my $input = <$client>;
5276: chomp($input);
1.226 foxr 5277:
1.234 foxr 5278: &Debug("get_request: Request = $input\n");
1.207 foxr 5279:
5280: &status('Processing '.$clientname.':'.$input);
5281:
5282: return $input;
5283: }
1.212 foxr 5284: #---------------------------------------------------------------
5285: #
5286: # Process a request. This sub should shrink as each action
5287: # gets farmed out into a separat sub that is registered
5288: # with the dispatch hash.
5289: #
5290: # Parameters:
5291: # user_input - The request received from the client (lonc).
5292: # Returns:
5293: # true to keep processing, false if caller should exit.
5294: #
5295: sub process_request {
5296: my ($userinput) = @_; # Easier for now to break style than to
5297: # fix all the userinput -> user_input.
5298: my $wasenc = 0; # True if request was encrypted.
5299: # ------------------------------------------------------------ See if encrypted
1.322 albertel 5300: # for command
5301: # sethost:<server>
5302: # <command>:<args>
5303: # we just send it to the processor
5304: # for
5305: # sethost:<server>:<command>:<args>
5306: # we do the implict set host and then do the command
5307: if ($userinput =~ /^sethost:/) {
5308: (my $cmd,my $newid,$userinput) = split(':',$userinput,3);
5309: if (defined($userinput)) {
5310: &sethost("$cmd:$newid");
5311: } else {
5312: $userinput = "$cmd:$newid";
5313: }
5314: }
5315:
1.212 foxr 5316: if ($userinput =~ /^enc/) {
5317: $userinput = decipher($userinput);
5318: $wasenc=1;
5319: if(!$userinput) { # Cipher not defined.
1.251 foxr 5320: &Failure($client, "error: Encrypted data without negotated key\n");
1.212 foxr 5321: return 0;
5322: }
5323: }
5324: Debug("process_request: $userinput\n");
5325:
1.213 foxr 5326: #
5327: # The 'correct way' to add a command to lond is now to
5328: # write a sub to execute it and Add it to the command dispatch
5329: # hash via a call to register_handler.. The comments to that
5330: # sub should give you enough to go on to show how to do this
5331: # along with the examples that are building up as this code
5332: # is getting refactored. Until all branches of the
5333: # if/elseif monster below have been factored out into
5334: # separate procesor subs, if the dispatch hash is missing
5335: # the command keyword, we will fall through to the remainder
5336: # of the if/else chain below in order to keep this thing in
5337: # working order throughout the transmogrification.
5338:
5339: my ($command, $tail) = split(/:/, $userinput, 2);
5340: chomp($command);
5341: chomp($tail);
5342: $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.
1.214 foxr 5343: $command =~ s/(\r)//; # And this too for parameterless commands.
5344: if(!$tail) {
5345: $tail =""; # defined but blank.
5346: }
1.213 foxr 5347:
5348: &Debug("Command received: $command, encoded = $wasenc");
5349:
5350: if(defined $Dispatcher{$command}) {
5351:
5352: my $dispatch_info = $Dispatcher{$command};
5353: my $handler = $$dispatch_info[0];
5354: my $need_encode = $$dispatch_info[1];
5355: my $client_types = $$dispatch_info[2];
5356: Debug("Matched dispatch hash: mustencode: $need_encode "
5357: ."ClientType $client_types");
5358:
5359: # Validate the request:
5360:
5361: my $ok = 1;
5362: my $requesterprivs = 0;
5363: if(&isClient()) {
5364: $requesterprivs |= $CLIENT_OK;
5365: }
5366: if(&isManager()) {
5367: $requesterprivs |= $MANAGER_OK;
5368: }
5369: if($need_encode && (!$wasenc)) {
5370: Debug("Must encode but wasn't: $need_encode $wasenc");
5371: $ok = 0;
5372: }
5373: if(($client_types & $requesterprivs) == 0) {
5374: Debug("Client not privileged to do this operation");
5375: $ok = 0;
5376: }
5377:
5378: if($ok) {
5379: Debug("Dispatching to handler $command $tail");
5380: my $keep_going = &$handler($command, $tail, $client);
5381: return $keep_going;
5382: } else {
5383: Debug("Refusing to dispatch because client did not match requirements");
5384: Failure($client, "refused\n", $userinput);
5385: return 1;
5386: }
5387:
5388: }
5389:
1.262 foxr 5390: print $client "unknown_cmd\n";
1.212 foxr 5391: # -------------------------------------------------------------------- complete
5392: Debug("process_request - returning 1");
5393: return 1;
5394: }
1.207 foxr 5395: #
5396: # Decipher encoded traffic
5397: # Parameters:
5398: # input - Encoded data.
5399: # Returns:
5400: # Decoded data or undef if encryption key was not yet negotiated.
5401: # Implicit input:
5402: # cipher - This global holds the negotiated encryption key.
5403: #
1.211 albertel 5404: sub decipher {
1.207 foxr 5405: my ($input) = @_;
5406: my $output = '';
1.212 foxr 5407:
5408:
1.207 foxr 5409: if($cipher) {
5410: my($enc, $enclength, $encinput) = split(/:/, $input);
5411: for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {
5412: $output .=
5413: $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));
5414: }
5415: return substr($output, 0, $enclength);
5416: } else {
5417: return undef;
5418: }
5419: }
5420:
5421: #
5422: # Register a command processor. This function is invoked to register a sub
5423: # to process a request. Once registered, the ProcessRequest sub can automatically
5424: # dispatch requests to an appropriate sub, and do the top level validity checking
5425: # as well:
5426: # - Is the keyword recognized.
5427: # - Is the proper client type attempting the request.
5428: # - Is the request encrypted if it has to be.
5429: # Parameters:
5430: # $request_name - Name of the request being registered.
5431: # This is the command request that will match
5432: # against the hash keywords to lookup the information
5433: # associated with the dispatch information.
5434: # $procedure - Reference to a sub to call to process the request.
5435: # All subs get called as follows:
5436: # Procedure($cmd, $tail, $replyfd, $key)
5437: # $cmd - the actual keyword that invoked us.
5438: # $tail - the tail of the request that invoked us.
5439: # $replyfd- File descriptor connected to the client
5440: # $must_encode - True if the request must be encoded to be good.
5441: # $client_ok - True if it's ok for a client to request this.
5442: # $manager_ok - True if it's ok for a manager to request this.
5443: # Side effects:
5444: # - On success, the Dispatcher hash has an entry added for the key $RequestName
5445: # - On failure, the program will die as it's a bad internal bug to try to
5446: # register a duplicate command handler.
5447: #
1.211 albertel 5448: sub register_handler {
1.212 foxr 5449: my ($request_name,$procedure,$must_encode, $client_ok,$manager_ok) = @_;
1.207 foxr 5450:
5451: # Don't allow duplication#
5452:
5453: if (defined $Dispatcher{$request_name}) {
5454: die "Attempting to define a duplicate request handler for $request_name\n";
5455: }
5456: # Build the client type mask:
5457:
5458: my $client_type_mask = 0;
5459: if($client_ok) {
5460: $client_type_mask |= $CLIENT_OK;
5461: }
5462: if($manager_ok) {
5463: $client_type_mask |= $MANAGER_OK;
5464: }
5465:
5466: # Enter the hash:
5467:
5468: my @entry = ($procedure, $must_encode, $client_type_mask);
5469:
5470: $Dispatcher{$request_name} = \@entry;
5471:
5472: }
5473:
5474:
5475: #------------------------------------------------------------------
5476:
5477:
5478:
5479:
1.141 foxr 5480: #
1.96 foxr 5481: # Convert an error return code from lcpasswd to a string value.
5482: #
5483: sub lcpasswdstrerror {
5484: my $ErrorCode = shift;
1.97 foxr 5485: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
1.96 foxr 5486: return "lcpasswd Unrecognized error return value ".$ErrorCode;
5487: } else {
1.98 foxr 5488: return $passwderrors[$ErrorCode];
1.96 foxr 5489: }
5490: }
5491:
1.97 foxr 5492: #
5493: # Convert an error return code from lcuseradd to a string value:
5494: #
5495: sub lcuseraddstrerror {
5496: my $ErrorCode = shift;
5497: if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
5498: return "lcuseradd - Unrecognized error code: ".$ErrorCode;
5499: } else {
1.98 foxr 5500: return $adderrors[$ErrorCode];
1.97 foxr 5501: }
5502: }
5503:
1.23 harris41 5504: # grabs exception and records it to log before exiting
5505: sub catchexception {
1.27 albertel 5506: my ($error)=@_;
1.25 www 5507: $SIG{'QUIT'}='DEFAULT';
5508: $SIG{__DIE__}='DEFAULT';
1.165 albertel 5509: &status("Catching exception");
1.190 albertel 5510: &logthis("<font color='red'>CRITICAL: "
1.373 albertel 5511: ."ABNORMAL EXIT. Child $$ for server ".$perlvar{'lonHostID'}." died through "
1.27 albertel 5512: ."a crash with this error msg->[$error]</font>");
1.57 www 5513: &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27 albertel 5514: if ($client) { print $client "error: $error\n"; }
1.59 www 5515: $server->close();
1.27 albertel 5516: die($error);
1.23 harris41 5517: }
1.63 www 5518: sub timeout {
1.165 albertel 5519: &status("Handling Timeout");
1.190 albertel 5520: &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
1.63 www 5521: &catchexception('Timeout');
5522: }
1.22 harris41 5523: # -------------------------------- Set signal handlers to record abnormal exits
5524:
1.226 foxr 5525:
1.22 harris41 5526: $SIG{'QUIT'}=\&catchexception;
5527: $SIG{__DIE__}=\&catchexception;
5528:
1.81 matthew 5529: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
1.95 harris41 5530: &status("Read loncapa.conf and loncapa_apache.conf");
5531: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.141 foxr 5532: %perlvar=%{$perlvarref};
1.80 harris41 5533: undef $perlvarref;
1.19 www 5534:
1.35 harris41 5535: # ----------------------------- Make sure this process is running from user=www
5536: my $wwwid=getpwnam('www');
5537: if ($wwwid!=$<) {
1.134 albertel 5538: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
5539: my $subj="LON: $currenthostid User ID mismatch";
1.37 harris41 5540: system("echo 'User ID mismatch. lond must be run as user www.' |\
1.35 harris41 5541: mailto $emailto -s '$subj' > /dev/null");
5542: exit 1;
5543: }
5544:
1.19 www 5545: # --------------------------------------------- Check if other instance running
5546:
5547: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
5548:
5549: if (-e $pidfile) {
5550: my $lfh=IO::File->new("$pidfile");
5551: my $pide=<$lfh>;
5552: chomp($pide);
1.29 harris41 5553: if (kill 0 => $pide) { die "already running"; }
1.19 www 5554: }
1.1 albertel 5555:
5556: # ------------------------------------------------------------- Read hosts file
5557:
5558:
5559:
5560: # establish SERVER socket, bind and listen.
5561: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
5562: Type => SOCK_STREAM,
5563: Proto => 'tcp',
5564: Reuse => 1,
5565: Listen => 10 )
1.29 harris41 5566: or die "making socket: $@\n";
1.1 albertel 5567:
5568: # --------------------------------------------------------- Do global variables
5569:
5570: # global variables
5571:
1.134 albertel 5572: my %children = (); # keys are current child process IDs
1.1 albertel 5573:
5574: sub REAPER { # takes care of dead children
5575: $SIG{CHLD} = \&REAPER;
1.165 albertel 5576: &status("Handling child death");
1.178 foxr 5577: my $pid;
5578: do {
5579: $pid = waitpid(-1,&WNOHANG());
5580: if (defined($children{$pid})) {
5581: &logthis("Child $pid died");
5582: delete($children{$pid});
1.183 albertel 5583: } elsif ($pid > 0) {
1.178 foxr 5584: &logthis("Unknown Child $pid died");
5585: }
5586: } while ( $pid > 0 );
5587: foreach my $child (keys(%children)) {
5588: $pid = waitpid($child,&WNOHANG());
5589: if ($pid > 0) {
5590: &logthis("Child $child - $pid looks like we missed it's death");
5591: delete($children{$pid});
5592: }
1.176 albertel 5593: }
1.165 albertel 5594: &status("Finished Handling child death");
1.1 albertel 5595: }
5596:
5597: sub HUNTSMAN { # signal handler for SIGINT
1.165 albertel 5598: &status("Killing children (INT)");
1.1 albertel 5599: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
5600: kill 'INT' => keys %children;
1.59 www 5601: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1 albertel 5602: my $execdir=$perlvar{'lonDaemons'};
5603: unlink("$execdir/logs/lond.pid");
1.190 albertel 5604: &logthis("<font color='red'>CRITICAL: Shutting down</font>");
1.165 albertel 5605: &status("Done killing children");
1.1 albertel 5606: exit; # clean up with dignity
5607: }
5608:
5609: sub HUPSMAN { # signal handler for SIGHUP
5610: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
1.165 albertel 5611: &status("Killing children for restart (HUP)");
1.1 albertel 5612: kill 'INT' => keys %children;
1.59 www 5613: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.190 albertel 5614: &logthis("<font color='red'>CRITICAL: Restarting</font>");
1.134 albertel 5615: my $execdir=$perlvar{'lonDaemons'};
1.30 harris41 5616: unlink("$execdir/logs/lond.pid");
1.165 albertel 5617: &status("Restarting self (HUP)");
1.1 albertel 5618: exec("$execdir/lond"); # here we go again
5619: }
5620:
1.144 foxr 5621: #
1.148 foxr 5622: # Reload the Apache daemon's state.
1.150 foxr 5623: # This is done by invoking /home/httpd/perl/apachereload
5624: # a setuid perl script that can be root for us to do this job.
1.148 foxr 5625: #
5626: sub ReloadApache {
1.150 foxr 5627: my $execdir = $perlvar{'lonDaemons'};
5628: my $script = $execdir."/apachereload";
5629: system($script);
1.148 foxr 5630: }
5631:
5632: #
1.144 foxr 5633: # Called in response to a USR2 signal.
5634: # - Reread hosts.tab
5635: # - All children connected to hosts that were removed from hosts.tab
5636: # are killed via SIGINT
5637: # - All children connected to previously existing hosts are sent SIGUSR1
5638: # - Our internal hosts hash is updated to reflect the new contents of
5639: # hosts.tab causing connections from hosts added to hosts.tab to
5640: # now be honored.
5641: #
5642: sub UpdateHosts {
1.165 albertel 5643: &status("Reload hosts.tab");
1.147 foxr 5644: logthis('<font color="blue"> Updating connections </font>');
1.148 foxr 5645: #
5646: # The %children hash has the set of IP's we currently have children
5647: # on. These need to be matched against records in the hosts.tab
5648: # Any ip's no longer in the table get killed off they correspond to
5649: # either dropped or changed hosts. Note that the re-read of the table
5650: # will take care of new and changed hosts as connections come into being.
5651:
1.371 albertel 5652: &Apache::lonnet::reset_hosts_info();
1.148 foxr 5653:
1.368 albertel 5654: foreach my $child (keys(%children)) {
1.148 foxr 5655: my $childip = $children{$child};
1.374 albertel 5656: if ($childip ne '127.0.0.1'
5657: && !defined(&Apache::lonnet::get_hosts_from_ip($childip))) {
1.149 foxr 5658: logthis('<font color="blue"> UpdateHosts killing child '
5659: ." $child for ip $childip </font>");
1.148 foxr 5660: kill('INT', $child);
1.149 foxr 5661: } else {
5662: logthis('<font color="green"> keeping child for ip '
5663: ." $childip (pid=$child) </font>");
1.148 foxr 5664: }
5665: }
5666: ReloadApache;
1.165 albertel 5667: &status("Finished reloading hosts.tab");
1.144 foxr 5668: }
5669:
1.148 foxr 5670:
1.57 www 5671: sub checkchildren {
1.165 albertel 5672: &status("Checking on the children (sending signals)");
1.57 www 5673: &initnewstatus();
5674: &logstatus();
5675: &logthis('Going to check on the children');
1.134 albertel 5676: my $docdir=$perlvar{'lonDocRoot'};
1.61 harris41 5677: foreach (sort keys %children) {
1.221 albertel 5678: #sleep 1;
1.57 www 5679: unless (kill 'USR1' => $_) {
5680: &logthis ('Child '.$_.' is dead');
5681: &logstatus($$.' is dead');
1.221 albertel 5682: delete($children{$_});
1.57 www 5683: }
1.61 harris41 5684: }
1.63 www 5685: sleep 5;
1.212 foxr 5686: $SIG{ALRM} = sub { Debug("timeout");
5687: die "timeout"; };
1.113 albertel 5688: $SIG{__DIE__} = 'DEFAULT';
1.165 albertel 5689: &status("Checking on the children (waiting for reports)");
1.63 www 5690: foreach (sort keys %children) {
5691: unless (-e "$docdir/lon-status/londchld/$_.txt") {
1.113 albertel 5692: eval {
5693: alarm(300);
1.63 www 5694: &logthis('Child '.$_.' did not respond');
1.67 albertel 5695: kill 9 => $_;
1.131 albertel 5696: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
5697: #$subj="LON: $currenthostid killed lond process $_";
5698: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
5699: #$execdir=$perlvar{'lonDaemons'};
5700: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
1.221 albertel 5701: delete($children{$_});
1.113 albertel 5702: alarm(0);
5703: }
1.63 www 5704: }
5705: }
1.113 albertel 5706: $SIG{ALRM} = 'DEFAULT';
1.155 albertel 5707: $SIG{__DIE__} = \&catchexception;
1.165 albertel 5708: &status("Finished checking children");
1.221 albertel 5709: &logthis('Finished Checking children');
1.57 www 5710: }
5711:
1.1 albertel 5712: # --------------------------------------------------------------------- Logging
5713:
5714: sub logthis {
5715: my $message=shift;
5716: my $execdir=$perlvar{'lonDaemons'};
5717: my $fh=IO::File->new(">>$execdir/logs/lond.log");
5718: my $now=time;
5719: my $local=localtime($now);
1.58 www 5720: $lastlog=$local.': '.$message;
1.1 albertel 5721: print $fh "$local ($$): $message\n";
5722: }
5723:
1.77 foxr 5724: # ------------------------- Conditional log if $DEBUG true.
5725: sub Debug {
5726: my $message = shift;
5727: if($DEBUG) {
5728: &logthis($message);
5729: }
5730: }
1.161 foxr 5731:
5732: #
5733: # Sub to do replies to client.. this gives a hook for some
5734: # debug tracing too:
5735: # Parameters:
5736: # fd - File open on client.
5737: # reply - Text to send to client.
5738: # request - Original request from client.
5739: #
5740: sub Reply {
1.192 foxr 5741: my ($fd, $reply, $request) = @_;
1.387 albertel 5742: if (ref($reply)) {
5743: print $fd $$reply;
5744: print $fd "\n";
5745: if ($DEBUG) { Debug("Request was $request Reply was $$reply"); }
5746: } else {
5747: print $fd $reply;
5748: if ($DEBUG) { Debug("Request was $request Reply was $reply"); }
5749: }
1.212 foxr 5750: $Transactions++;
5751: }
5752:
5753:
5754: #
5755: # Sub to report a failure.
5756: # This function:
5757: # - Increments the failure statistic counters.
5758: # - Invokes Reply to send the error message to the client.
5759: # Parameters:
5760: # fd - File descriptor open on the client
5761: # reply - Reply text to emit.
5762: # request - The original request message (used by Reply
5763: # to debug if that's enabled.
5764: # Implicit outputs:
5765: # $Failures- The number of failures is incremented.
5766: # Reply (invoked here) sends a message to the
5767: # client:
5768: #
5769: sub Failure {
5770: my $fd = shift;
5771: my $reply = shift;
5772: my $request = shift;
5773:
5774: $Failures++;
5775: Reply($fd, $reply, $request); # That's simple eh?
1.161 foxr 5776: }
1.57 www 5777: # ------------------------------------------------------------------ Log status
5778:
5779: sub logstatus {
1.178 foxr 5780: &status("Doing logging");
5781: my $docdir=$perlvar{'lonDocRoot'};
5782: {
5783: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
1.200 matthew 5784: print $fh $status."\n".$lastlog."\n".time."\n$keymode";
1.178 foxr 5785: $fh->close();
5786: }
1.221 albertel 5787: &status("Finished $$.txt");
5788: {
5789: open(LOG,">>$docdir/lon-status/londstatus.txt");
5790: flock(LOG,LOCK_EX);
5791: print LOG $$."\t".$clientname."\t".$currenthostid."\t"
5792: .$status."\t".$lastlog."\t $keymode\n";
1.275 albertel 5793: flock(LOG,LOCK_UN);
1.221 albertel 5794: close(LOG);
5795: }
1.178 foxr 5796: &status("Finished logging");
1.57 www 5797: }
5798:
5799: sub initnewstatus {
5800: my $docdir=$perlvar{'lonDocRoot'};
5801: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
5802: my $now=time;
5803: my $local=localtime($now);
5804: print $fh "LOND status $local - parent $$\n\n";
1.64 www 5805: opendir(DIR,"$docdir/lon-status/londchld");
1.134 albertel 5806: while (my $filename=readdir(DIR)) {
1.64 www 5807: unlink("$docdir/lon-status/londchld/$filename");
5808: }
5809: closedir(DIR);
1.57 www 5810: }
5811:
5812: # -------------------------------------------------------------- Status setting
5813:
5814: sub status {
5815: my $what=shift;
5816: my $now=time;
5817: my $local=localtime($now);
1.178 foxr 5818: $status=$local.': '.$what;
5819: $0='lond: '.$what.' '.$local;
1.57 www 5820: }
1.11 www 5821:
1.13 www 5822: # -------------------------------------------------------------- Talk to lonsql
5823:
1.234 foxr 5824: sub sql_reply {
1.12 harris41 5825: my ($cmd)=@_;
1.234 foxr 5826: my $answer=&sub_sql_reply($cmd);
5827: if ($answer eq 'con_lost') { $answer=&sub_sql_reply($cmd); }
1.12 harris41 5828: return $answer;
5829: }
5830:
1.234 foxr 5831: sub sub_sql_reply {
1.12 harris41 5832: my ($cmd)=@_;
5833: my $unixsock="mysqlsock";
5834: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
5835: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
5836: Type => SOCK_STREAM,
5837: Timeout => 10)
5838: or return "con_lost";
1.319 www 5839: print $sclient "$cmd:$currentdomainid\n";
1.12 harris41 5840: my $answer=<$sclient>;
5841: chomp($answer);
5842: if (!$answer) { $answer="con_lost"; }
5843: return $answer;
5844: }
5845:
1.1 albertel 5846: # --------------------------------------- Is this the home server of an author?
1.11 www 5847:
1.1 albertel 5848: sub ishome {
5849: my $author=shift;
5850: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
5851: my ($udom,$uname)=split(/\//,$author);
5852: my $proname=propath($udom,$uname);
5853: if (-e $proname) {
5854: return 'owner';
5855: } else {
5856: return 'not_owner';
5857: }
5858: }
5859:
5860: # ======================================================= Continue main program
5861: # ---------------------------------------------------- Fork once and dissociate
5862:
1.134 albertel 5863: my $fpid=fork;
1.1 albertel 5864: exit if $fpid;
1.29 harris41 5865: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 5866:
1.29 harris41 5867: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 5868:
5869: # ------------------------------------------------------- Write our PID on disk
5870:
1.134 albertel 5871: my $execdir=$perlvar{'lonDaemons'};
1.1 albertel 5872: open (PIDSAVE,">$execdir/logs/lond.pid");
5873: print PIDSAVE "$$\n";
5874: close(PIDSAVE);
1.190 albertel 5875: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
1.57 www 5876: &status('Starting');
1.1 albertel 5877:
1.106 foxr 5878:
1.1 albertel 5879:
5880: # ----------------------------------------------------- Install signal handlers
5881:
1.57 www 5882:
1.1 albertel 5883: $SIG{CHLD} = \&REAPER;
5884: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
5885: $SIG{HUP} = \&HUPSMAN;
1.57 www 5886: $SIG{USR1} = \&checkchildren;
1.144 foxr 5887: $SIG{USR2} = \&UpdateHosts;
1.106 foxr 5888:
1.148 foxr 5889: # Read the host hashes:
1.368 albertel 5890: &Apache::lonnet::load_hosts_tab();
1.106 foxr 5891:
1.286 albertel 5892: my $dist=`$perlvar{'lonDaemons'}/distprobe`;
5893:
1.106 foxr 5894: # --------------------------------------------------------------
5895: # Accept connections. When a connection comes in, it is validated
5896: # and if good, a child process is created to process transactions
5897: # along the connection.
5898:
1.1 albertel 5899: while (1) {
1.165 albertel 5900: &status('Starting accept');
1.106 foxr 5901: $client = $server->accept() or next;
1.165 albertel 5902: &status('Accepted '.$client.' off to spawn');
1.386 albertel 5903: make_new_child($client);
1.165 albertel 5904: &status('Finished spawning');
1.1 albertel 5905: }
5906:
1.212 foxr 5907: sub make_new_child {
5908: my $pid;
5909: # my $cipher; # Now global
5910: my $sigset;
1.178 foxr 5911:
1.212 foxr 5912: $client = shift;
5913: &status('Starting new child '.$client);
5914: &logthis('<font color="green"> Attempting to start child ('.$client.
5915: ")</font>");
5916: # block signal for fork
5917: $sigset = POSIX::SigSet->new(SIGINT);
5918: sigprocmask(SIG_BLOCK, $sigset)
5919: or die "Can't block SIGINT for fork: $!\n";
1.178 foxr 5920:
1.212 foxr 5921: die "fork: $!" unless defined ($pid = fork);
1.178 foxr 5922:
1.212 foxr 5923: $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
5924: # connection liveness.
1.178 foxr 5925:
1.212 foxr 5926: #
5927: # Figure out who we're talking to so we can record the peer in
5928: # the pid hash.
5929: #
5930: my $caller = getpeername($client);
5931: my ($port,$iaddr);
5932: if (defined($caller) && length($caller) > 0) {
5933: ($port,$iaddr)=unpack_sockaddr_in($caller);
5934: } else {
5935: &logthis("Unable to determine who caller was, getpeername returned nothing");
5936: }
5937: if (defined($iaddr)) {
5938: $clientip = inet_ntoa($iaddr);
5939: Debug("Connected with $clientip");
5940: } else {
5941: &logthis("Unable to determine clientip");
5942: $clientip='Unavailable';
5943: }
5944:
5945: if ($pid) {
5946: # Parent records the child's birth and returns.
5947: sigprocmask(SIG_UNBLOCK, $sigset)
5948: or die "Can't unblock SIGINT for fork: $!\n";
5949: $children{$pid} = $clientip;
5950: &status('Started child '.$pid);
5951: return;
5952: } else {
5953: # Child can *not* return from this subroutine.
5954: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
5955: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
5956: #don't get intercepted
5957: $SIG{USR1}= \&logstatus;
5958: $SIG{ALRM}= \&timeout;
5959: $lastlog='Forked ';
5960: $status='Forked';
1.178 foxr 5961:
1.212 foxr 5962: # unblock signals
5963: sigprocmask(SIG_UNBLOCK, $sigset)
5964: or die "Can't unblock SIGINT for fork: $!\n";
1.178 foxr 5965:
1.212 foxr 5966: # my $tmpsnum=0; # Now global
5967: #---------------------------------------------------- kerberos 5 initialization
5968: &Authen::Krb5::init_context();
1.359 raeburn 5969: unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||
5970: ($dist eq 'fedora6') || ($dist eq 'suse9.3')) {
1.286 albertel 5971: &Authen::Krb5::init_ets();
5972: }
1.209 albertel 5973:
1.212 foxr 5974: &status('Accepted connection');
5975: # =============================================================================
5976: # do something with the connection
5977: # -----------------------------------------------------------------------------
5978: # see if we know client and 'check' for spoof IP by ineffective challenge
1.178 foxr 5979:
1.278 albertel 5980: my $outsideip=$clientip;
5981: if ($clientip eq '127.0.0.1') {
1.368 albertel 5982: $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
1.278 albertel 5983: }
5984:
1.368 albertel 5985: my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
1.278 albertel 5986: my $ismanager=($managers{$outsideip} ne undef);
1.212 foxr 5987: $clientname = "[unknonwn]";
5988: if($clientrec) { # Establish client type.
5989: $ConnectionType = "client";
1.368 albertel 5990: $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
1.212 foxr 5991: if($ismanager) {
5992: $ConnectionType = "both";
5993: }
5994: } else {
5995: $ConnectionType = "manager";
1.278 albertel 5996: $clientname = $managers{$outsideip};
1.212 foxr 5997: }
5998: my $clientok;
1.178 foxr 5999:
1.212 foxr 6000: if ($clientrec || $ismanager) {
6001: &status("Waiting for init from $clientip $clientname");
6002: &logthis('<font color="yellow">INFO: Connection, '.
6003: $clientip.
6004: " ($clientname) connection type = $ConnectionType </font>" );
6005: &status("Connecting $clientip ($clientname))");
6006: my $remotereq=<$client>;
6007: chomp($remotereq);
6008: Debug("Got init: $remotereq");
1.337 albertel 6009:
1.212 foxr 6010: if ($remotereq =~ /^init/) {
6011: &sethost("sethost:$perlvar{'lonHostID'}");
6012: #
6013: # If the remote is attempting a local init... give that a try:
6014: #
6015: my ($i, $inittype) = split(/:/, $remotereq);
1.209 albertel 6016:
1.212 foxr 6017: # If the connection type is ssl, but I didn't get my
6018: # certificate files yet, then I'll drop back to
6019: # insecure (if allowed).
6020:
6021: if($inittype eq "ssl") {
6022: my ($ca, $cert) = lonssl::CertificateFile;
6023: my $kfile = lonssl::KeyFile;
6024: if((!$ca) ||
6025: (!$cert) ||
6026: (!$kfile)) {
6027: $inittype = ""; # This forces insecure attempt.
6028: &logthis("<font color=\"blue\"> Certificates not "
6029: ."installed -- trying insecure auth</font>");
1.224 foxr 6030: } else { # SSL certificates are in place so
1.212 foxr 6031: } # Leave the inittype alone.
6032: }
6033:
6034: if($inittype eq "local") {
6035: my $key = LocalConnection($client, $remotereq);
6036: if($key) {
6037: Debug("Got local key $key");
6038: $clientok = 1;
6039: my $cipherkey = pack("H32", $key);
6040: $cipher = new IDEA($cipherkey);
6041: print $client "ok:local\n";
6042: &logthis('<font color="green"'
6043: . "Successful local authentication </font>");
6044: $keymode = "local"
1.178 foxr 6045: } else {
1.212 foxr 6046: Debug("Failed to get local key");
6047: $clientok = 0;
6048: shutdown($client, 3);
6049: close $client;
1.178 foxr 6050: }
1.212 foxr 6051: } elsif ($inittype eq "ssl") {
6052: my $key = SSLConnection($client);
6053: if ($key) {
6054: $clientok = 1;
6055: my $cipherkey = pack("H32", $key);
6056: $cipher = new IDEA($cipherkey);
6057: &logthis('<font color="green">'
6058: ."Successfull ssl authentication with $clientname </font>");
6059: $keymode = "ssl";
6060:
1.178 foxr 6061: } else {
1.212 foxr 6062: $clientok = 0;
6063: close $client;
1.178 foxr 6064: }
1.212 foxr 6065:
6066: } else {
6067: my $ok = InsecureConnection($client);
6068: if($ok) {
6069: $clientok = 1;
6070: &logthis('<font color="green">'
6071: ."Successful insecure authentication with $clientname </font>");
6072: print $client "ok\n";
6073: $keymode = "insecure";
1.178 foxr 6074: } else {
1.212 foxr 6075: &logthis('<font color="yellow">'
6076: ."Attempted insecure connection disallowed </font>");
6077: close $client;
6078: $clientok = 0;
1.178 foxr 6079:
6080: }
6081: }
1.212 foxr 6082: } else {
6083: &logthis(
6084: "<font color='blue'>WARNING: "
6085: ."$clientip failed to initialize: >$remotereq< </font>");
6086: &status('No init '.$clientip);
6087: }
6088:
6089: } else {
6090: &logthis(
6091: "<font color='blue'>WARNING: Unknown client $clientip</font>");
6092: &status('Hung up on '.$clientip);
6093: }
6094:
6095: if ($clientok) {
6096: # ---------------- New known client connecting, could mean machine online again
1.368 albertel 6097: if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip
1.367 albertel 6098: && $clientip ne '127.0.0.1') {
1.375 albertel 6099: &Apache::lonnet::reconlonc($clientname);
1.212 foxr 6100: }
6101: &logthis("<font color='green'>Established connection: $clientname</font>");
6102: &status('Will listen to '.$clientname);
6103: # ------------------------------------------------------------ Process requests
6104: my $keep_going = 1;
6105: my $user_input;
6106: while(($user_input = get_request) && $keep_going) {
6107: alarm(120);
6108: Debug("Main: Got $user_input\n");
6109: $keep_going = &process_request($user_input);
1.178 foxr 6110: alarm(0);
1.212 foxr 6111: &status('Listening to '.$clientname." ($keymode)");
1.161 foxr 6112: }
1.212 foxr 6113:
1.59 www 6114: # --------------------------------------------- client unknown or fishy, refuse
1.212 foxr 6115: } else {
1.161 foxr 6116: print $client "refused\n";
6117: $client->close();
1.190 albertel 6118: &logthis("<font color='blue'>WARNING: "
1.161 foxr 6119: ."Rejected client $clientip, closing connection</font>");
6120: }
1.212 foxr 6121: }
1.161 foxr 6122:
1.1 albertel 6123: # =============================================================================
1.161 foxr 6124:
1.190 albertel 6125: &logthis("<font color='red'>CRITICAL: "
1.161 foxr 6126: ."Disconnect from $clientip ($clientname)</font>");
6127:
6128:
6129: # this exit is VERY important, otherwise the child will become
6130: # a producer of more and more children, forking yourself into
6131: # process death.
6132: exit;
1.106 foxr 6133:
1.78 foxr 6134: }
1.261 foxr 6135: #
6136: # Determine if a user is an author for the indicated domain.
6137: #
6138: # Parameters:
6139: # domain - domain to check in .
6140: # user - Name of user to check.
6141: #
6142: # Return:
6143: # 1 - User is an author for domain.
6144: # 0 - User is not an author for domain.
6145: sub is_author {
6146: my ($domain, $user) = @_;
6147:
6148: &Debug("is_author: $user @ $domain");
6149:
6150: my $hashref = &tie_user_hash($domain, $user, "roles",
6151: &GDBM_READER());
6152:
6153: # Author role should show up as a key /domain/_au
1.78 foxr 6154:
1.321 albertel 6155: my $key = "/$domain/_au";
6156: my $value;
6157: if (defined($hashref)) {
6158: $value = $hashref->{$key};
6159: }
1.78 foxr 6160:
1.261 foxr 6161: if(defined($value)) {
6162: &Debug("$user @ $domain is an author");
6163: }
6164:
6165: return defined($value);
6166: }
1.78 foxr 6167: #
6168: # Checks to see if the input roleput request was to set
6169: # an author role. If so, invokes the lchtmldir script to set
6170: # up a correct public_html
6171: # Parameters:
6172: # request - The request sent to the rolesput subchunk.
6173: # We're looking for /domain/_au
6174: # domain - The domain in which the user is having roles doctored.
6175: # user - Name of the user for which the role is being put.
6176: # authtype - The authentication type associated with the user.
6177: #
1.289 albertel 6178: sub manage_permissions {
1.192 foxr 6179: my ($request, $domain, $user, $authtype) = @_;
1.78 foxr 6180:
1.261 foxr 6181: &Debug("manage_permissions: $request $domain $user $authtype");
6182:
1.78 foxr 6183: # See if the request is of the form /$domain/_au
1.289 albertel 6184: if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
1.78 foxr 6185: my $execdir = $perlvar{'lonDaemons'};
6186: my $userhome= "/home/$user" ;
1.134 albertel 6187: &logthis("system $execdir/lchtmldir $userhome $user $authtype");
1.261 foxr 6188: &Debug("Setting homedir permissions for $userhome");
1.78 foxr 6189: system("$execdir/lchtmldir $userhome $user $authtype");
6190: }
6191: }
1.222 foxr 6192:
6193:
6194: #
6195: # Return the full path of a user password file, whether it exists or not.
6196: # Parameters:
6197: # domain - Domain in which the password file lives.
6198: # user - name of the user.
6199: # Returns:
6200: # Full passwd path:
6201: #
6202: sub password_path {
6203: my ($domain, $user) = @_;
1.264 albertel 6204: return &propath($domain, $user).'/passwd';
1.222 foxr 6205: }
6206:
6207: # Password Filename
6208: # Returns the path to a passwd file given domain and user... only if
6209: # it exists.
6210: # Parameters:
6211: # domain - Domain in which to search.
6212: # user - username.
6213: # Returns:
6214: # - If the password file exists returns its path.
6215: # - If the password file does not exist, returns undefined.
6216: #
6217: sub password_filename {
6218: my ($domain, $user) = @_;
6219:
6220: Debug ("PasswordFilename called: dom = $domain user = $user");
6221:
6222: my $path = &password_path($domain, $user);
6223: Debug("PasswordFilename got path: $path");
6224: if(-e $path) {
6225: return $path;
6226: } else {
6227: return undef;
6228: }
6229: }
6230:
6231: #
6232: # Rewrite the contents of the user's passwd file.
6233: # Parameters:
6234: # domain - domain of the user.
6235: # name - User's name.
6236: # contents - New contents of the file.
6237: # Returns:
6238: # 0 - Failed.
6239: # 1 - Success.
6240: #
6241: sub rewrite_password_file {
6242: my ($domain, $user, $contents) = @_;
6243:
6244: my $file = &password_filename($domain, $user);
6245: if (defined $file) {
6246: my $pf = IO::File->new(">$file");
6247: if($pf) {
6248: print $pf "$contents\n";
6249: return 1;
6250: } else {
6251: return 0;
6252: }
6253: } else {
6254: return 0;
6255: }
6256:
6257: }
6258:
1.78 foxr 6259: #
1.222 foxr 6260: # get_auth_type - Determines the authorization type of a user in a domain.
1.78 foxr 6261:
6262: # Returns the authorization type or nouser if there is no such user.
6263: #
1.222 foxr 6264: sub get_auth_type
1.78 foxr 6265: {
1.192 foxr 6266:
6267: my ($domain, $user) = @_;
1.78 foxr 6268:
1.222 foxr 6269: Debug("get_auth_type( $domain, $user ) \n");
1.78 foxr 6270: my $proname = &propath($domain, $user);
6271: my $passwdfile = "$proname/passwd";
6272: if( -e $passwdfile ) {
6273: my $pf = IO::File->new($passwdfile);
6274: my $realpassword = <$pf>;
6275: chomp($realpassword);
1.79 foxr 6276: Debug("Password info = $realpassword\n");
1.78 foxr 6277: my ($authtype, $contentpwd) = split(/:/, $realpassword);
1.79 foxr 6278: Debug("Authtype = $authtype, content = $contentpwd\n");
1.259 raeburn 6279: return "$authtype:$contentpwd";
1.224 foxr 6280: } else {
1.79 foxr 6281: Debug("Returning nouser");
1.78 foxr 6282: return "nouser";
6283: }
1.1 albertel 6284: }
6285:
1.220 foxr 6286: #
6287: # Validate a user given their domain, name and password. This utility
6288: # function is used by both AuthenticateHandler and ChangePasswordHandler
6289: # to validate the login credentials of a user.
6290: # Parameters:
6291: # $domain - The domain being logged into (this is required due to
6292: # the capability for multihomed systems.
6293: # $user - The name of the user being validated.
6294: # $password - The user's propoposed password.
6295: #
6296: # Returns:
6297: # 1 - The domain,user,pasword triplet corresponds to a valid
6298: # user.
6299: # 0 - The domain,user,password triplet is not a valid user.
6300: #
6301: sub validate_user {
1.396 raeburn 6302: my ($domain, $user, $password, $checkdefauth) = @_;
1.220 foxr 6303:
6304: # Why negative ~pi you may well ask? Well this function is about
6305: # authentication, and therefore very important to get right.
6306: # I've initialized the flag that determines whether or not I've
6307: # validated correctly to a value it's not supposed to get.
6308: # At the end of this function. I'll ensure that it's not still that
6309: # value so we don't just wind up returning some accidental value
6310: # as a result of executing an unforseen code path that
1.249 foxr 6311: # did not set $validated. At the end of valid execution paths,
6312: # validated shoule be 1 for success or 0 for failuer.
1.220 foxr 6313:
6314: my $validated = -3.14159;
6315:
6316: # How we authenticate is determined by the type of authentication
6317: # the user has been assigned. If the authentication type is
6318: # "nouser", the user does not exist so we will return 0.
6319:
1.222 foxr 6320: my $contents = &get_auth_type($domain, $user);
1.220 foxr 6321: my ($howpwd, $contentpwd) = split(/:/, $contents);
6322:
6323: my $null = pack("C",0); # Used by kerberos auth types.
6324:
1.395 raeburn 6325: if ($howpwd eq 'nouser') {
1.396 raeburn 6326: if ($checkdefauth) {
6327: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
6328: if ($domdefaults{'auth_def'} eq 'localauth') {
6329: $howpwd = $domdefaults{'auth_def'};
6330: $contentpwd = $domdefaults{'auth_arg_def'};
6331: } elsif ((($domdefaults{'auth_def'} eq 'krb4') ||
6332: ($domdefaults{'auth_def'} eq 'krb5')) &&
6333: ($domdefaults{'auth_arg_def'} ne '')) {
6334: $howpwd = $domdefaults{'auth_def'};
6335: $contentpwd = $domdefaults{'auth_arg_def'};
6336: }
1.395 raeburn 6337: }
6338: }
1.220 foxr 6339: if ($howpwd ne 'nouser') {
6340: if($howpwd eq "internal") { # Encrypted is in local password file.
6341: $validated = (crypt($password, $contentpwd) eq $contentpwd);
6342: }
6343: elsif ($howpwd eq "unix") { # User is a normal unix user.
6344: $contentpwd = (getpwnam($user))[1];
6345: if($contentpwd) {
6346: if($contentpwd eq 'x') { # Shadow password file...
6347: my $pwauth_path = "/usr/local/sbin/pwauth";
6348: open PWAUTH, "|$pwauth_path" or
6349: die "Cannot invoke authentication";
6350: print PWAUTH "$user\n$password\n";
6351: close PWAUTH;
6352: $validated = ! $?;
6353:
6354: } else { # Passwords in /etc/passwd.
6355: $validated = (crypt($password,
6356: $contentpwd) eq $contentpwd);
6357: }
6358: } else {
6359: $validated = 0;
6360: }
6361: }
6362: elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
6363: if(! ($password =~ /$null/) ) {
6364: my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
6365: "",
6366: $contentpwd,,
6367: 'krbtgt',
6368: $contentpwd,
6369: 1,
6370: $password);
6371: if(!$k4error) {
6372: $validated = 1;
1.224 foxr 6373: } else {
1.220 foxr 6374: $validated = 0;
6375: &logthis('krb4: '.$user.', '.$contentpwd.', '.
6376: &Authen::Krb4::get_err_txt($Authen::Krb4::error));
6377: }
1.224 foxr 6378: } else {
1.220 foxr 6379: $validated = 0; # Password has a match with null.
6380: }
1.224 foxr 6381: } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
1.220 foxr 6382: if(!($password =~ /$null/)) { # Null password not allowed.
6383: my $krbclient = &Authen::Krb5::parse_name($user.'@'
6384: .$contentpwd);
6385: my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
6386: my $krbserver = &Authen::Krb5::parse_name($krbservice);
6387: my $credentials= &Authen::Krb5::cc_default();
1.359 raeburn 6388: $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
6389: .$contentpwd));
1.394 raeburn 6390: my $krbreturn;
6391: if (exists(&Authen::Krb5::get_init_creds_password)) {
6392: $krbreturn =
6393: &Authen::Krb5::get_init_creds_password($krbclient,$password,
6394: $krbservice);
6395: $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
6396: } else {
6397: $krbreturn =
6398: &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
6399: $password,$credentials);
6400: $validated = ($krbreturn == 1);
6401: }
1.380 albertel 6402: if (!$validated) {
6403: &logthis('krb5: '.$user.', '.$contentpwd.', '.
6404: &Authen::Krb5::error());
6405: }
1.224 foxr 6406: } else {
1.220 foxr 6407: $validated = 0;
6408: }
1.224 foxr 6409: } elsif ($howpwd eq "localauth") {
1.220 foxr 6410: # Authenticate via installation specific authentcation method:
6411: $validated = &localauth::localauth($user,
6412: $password,
1.353 albertel 6413: $contentpwd,
6414: $domain);
1.358 albertel 6415: if ($validated < 0) {
1.357 albertel 6416: &logthis("localauth for $contentpwd $user:$domain returned a $validated");
6417: $validated = 0;
6418: }
1.224 foxr 6419: } else { # Unrecognized auth is also bad.
1.220 foxr 6420: $validated = 0;
6421: }
6422: } else {
6423: $validated = 0;
6424: }
6425: #
6426: # $validated has the correct stat of the authentication:
6427: #
6428:
6429: unless ($validated != -3.14159) {
1.249 foxr 6430: # I >really really< want to know if this happens.
6431: # since it indicates that user authentication is badly
6432: # broken in some code path.
6433: #
6434: die "ValidateUser - failed to set the value of validated $domain, $user $password";
1.220 foxr 6435: }
6436: return $validated;
6437: }
6438:
6439:
1.84 albertel 6440: sub addline {
6441: my ($fname,$hostid,$ip,$newline)=@_;
6442: my $contents;
6443: my $found=0;
1.355 albertel 6444: my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':';
1.134 albertel 6445: my $sh;
1.84 albertel 6446: if ($sh=IO::File->new("$fname.subscription")) {
6447: while (my $subline=<$sh>) {
6448: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
6449: }
6450: $sh->close();
6451: }
6452: $sh=IO::File->new(">$fname.subscription");
6453: if ($contents) { print $sh $contents; }
6454: if ($newline) { print $sh $newline; }
6455: $sh->close();
6456: return $found;
1.86 www 6457: }
6458:
1.234 foxr 6459: sub get_chat {
1.324 raeburn 6460: my ($cdom,$cname,$udom,$uname,$group)=@_;
1.310 albertel 6461:
1.87 www 6462: my @entries=();
1.324 raeburn 6463: my $namespace = 'nohist_chatroom';
6464: my $namespace_inroom = 'nohist_inchatroom';
1.335 albertel 6465: if ($group ne '') {
1.324 raeburn 6466: $namespace .= '_'.$group;
6467: $namespace_inroom .= '_'.$group;
6468: }
6469: my $hashref = &tie_user_hash($cdom, $cname, $namespace,
1.310 albertel 6470: &GDBM_READER());
6471: if ($hashref) {
6472: @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
1.311 albertel 6473: &untie_user_hash($hashref);
1.123 www 6474: }
1.124 www 6475: my @participants=();
1.134 albertel 6476: my $cutoff=time-60;
1.324 raeburn 6477: $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom,
1.310 albertel 6478: &GDBM_WRCREAT());
6479: if ($hashref) {
6480: $hashref->{$uname.':'.$udom}=time;
6481: foreach my $user (sort(keys(%$hashref))) {
6482: if ($hashref->{$user}>$cutoff) {
6483: push(@participants, 'active_participant:'.$user);
1.123 www 6484: }
6485: }
1.311 albertel 6486: &untie_user_hash($hashref);
1.86 www 6487: }
1.124 www 6488: return (@participants,@entries);
1.86 www 6489: }
6490:
1.234 foxr 6491: sub chat_add {
1.324 raeburn 6492: my ($cdom,$cname,$newchat,$group)=@_;
1.88 albertel 6493: my @entries=();
1.142 www 6494: my $time=time;
1.324 raeburn 6495: my $namespace = 'nohist_chatroom';
6496: my $logfile = 'chatroom.log';
1.335 albertel 6497: if ($group ne '') {
1.324 raeburn 6498: $namespace .= '_'.$group;
6499: $logfile = 'chatroom_'.$group.'.log';
6500: }
6501: my $hashref = &tie_user_hash($cdom, $cname, $namespace,
1.310 albertel 6502: &GDBM_WRCREAT());
6503: if ($hashref) {
6504: @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
1.88 albertel 6505: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
6506: my ($thentime,$idnum)=split(/\_/,$lastid);
6507: my $newid=$time.'_000000';
6508: if ($thentime==$time) {
6509: $idnum=~s/^0+//;
6510: $idnum++;
6511: $idnum=substr('000000'.$idnum,-6,6);
6512: $newid=$time.'_'.$idnum;
6513: }
1.310 albertel 6514: $hashref->{$newid}=$newchat;
1.88 albertel 6515: my $expired=$time-3600;
1.310 albertel 6516: foreach my $comment (keys(%$hashref)) {
6517: my ($thistime) = ($comment=~/(\d+)\_/);
1.88 albertel 6518: if ($thistime<$expired) {
1.310 albertel 6519: delete $hashref->{$comment};
1.88 albertel 6520: }
6521: }
1.310 albertel 6522: {
6523: my $proname=&propath($cdom,$cname);
1.324 raeburn 6524: if (open(CHATLOG,">>$proname/$logfile")) {
1.310 albertel 6525: print CHATLOG ("$time:".&unescape($newchat)."\n");
6526: }
6527: close(CHATLOG);
1.142 www 6528: }
1.311 albertel 6529: &untie_user_hash($hashref);
1.86 www 6530: }
1.84 albertel 6531: }
6532:
6533: sub unsub {
6534: my ($fname,$clientip)=@_;
6535: my $result;
1.188 foxr 6536: my $unsubs = 0; # Number of successful unsubscribes:
6537:
6538:
6539: # An old way subscriptions were handled was to have a
6540: # subscription marker file:
6541:
6542: Debug("Attempting unlink of $fname.$clientname");
1.161 foxr 6543: if (unlink("$fname.$clientname")) {
1.188 foxr 6544: $unsubs++; # Successful unsub via marker file.
6545: }
6546:
6547: # The more modern way to do it is to have a subscription list
6548: # file:
6549:
1.84 albertel 6550: if (-e "$fname.subscription") {
1.161 foxr 6551: my $found=&addline($fname,$clientname,$clientip,'');
1.188 foxr 6552: if ($found) {
6553: $unsubs++;
6554: }
6555: }
6556:
6557: # If either or both of these mechanisms succeeded in unsubscribing a
6558: # resource we can return ok:
6559:
6560: if($unsubs) {
6561: $result = "ok\n";
1.84 albertel 6562: } else {
1.188 foxr 6563: $result = "not_subscribed\n";
1.84 albertel 6564: }
1.188 foxr 6565:
1.84 albertel 6566: return $result;
6567: }
6568:
1.101 www 6569: sub currentversion {
6570: my $fname=shift;
6571: my $version=-1;
6572: my $ulsdir='';
6573: if ($fname=~/^(.+)\/[^\/]+$/) {
6574: $ulsdir=$1;
6575: }
1.114 albertel 6576: my ($fnamere1,$fnamere2);
6577: # remove version if already specified
1.101 www 6578: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
1.114 albertel 6579: # get the bits that go before and after the version number
6580: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
6581: $fnamere1=$1;
6582: $fnamere2='.'.$2;
6583: }
1.101 www 6584: if (-e $fname) { $version=1; }
6585: if (-e $ulsdir) {
1.134 albertel 6586: if(-d $ulsdir) {
6587: if (opendir(LSDIR,$ulsdir)) {
6588: my $ulsfn;
6589: while ($ulsfn=readdir(LSDIR)) {
1.101 www 6590: # see if this is a regular file (ignore links produced earlier)
1.134 albertel 6591: my $thisfile=$ulsdir.'/'.$ulsfn;
6592: unless (-l $thisfile) {
1.160 www 6593: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) {
1.134 albertel 6594: if ($1>$version) { $version=$1; }
6595: }
6596: }
6597: }
6598: closedir(LSDIR);
6599: $version++;
6600: }
6601: }
6602: }
6603: return $version;
1.101 www 6604: }
6605:
6606: sub thisversion {
6607: my $fname=shift;
6608: my $version=-1;
6609: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
6610: $version=$1;
6611: }
6612: return $version;
6613: }
6614:
1.84 albertel 6615: sub subscribe {
6616: my ($userinput,$clientip)=@_;
6617: my $result;
1.293 albertel 6618: my ($cmd,$fname)=split(/:/,$userinput,2);
1.84 albertel 6619: my $ownership=&ishome($fname);
6620: if ($ownership eq 'owner') {
1.101 www 6621: # explitly asking for the current version?
6622: unless (-e $fname) {
6623: my $currentversion=¤tversion($fname);
6624: if (&thisversion($fname)==$currentversion) {
6625: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
6626: my $root=$1;
6627: my $extension=$2;
6628: symlink($root.'.'.$extension,
6629: $root.'.'.$currentversion.'.'.$extension);
1.102 www 6630: unless ($extension=~/\.meta$/) {
6631: symlink($root.'.'.$extension.'.meta',
6632: $root.'.'.$currentversion.'.'.$extension.'.meta');
6633: }
1.101 www 6634: }
6635: }
6636: }
1.84 albertel 6637: if (-e $fname) {
6638: if (-d $fname) {
6639: $result="directory\n";
6640: } else {
1.161 foxr 6641: if (-e "$fname.$clientname") {&unsub($fname,$clientip);}
1.134 albertel 6642: my $now=time;
1.161 foxr 6643: my $found=&addline($fname,$clientname,$clientip,
6644: "$clientname:$clientip:$now\n");
1.84 albertel 6645: if ($found) { $result="$fname\n"; }
6646: # if they were subscribed to only meta data, delete that
6647: # subscription, when you subscribe to a file you also get
6648: # the metadata
6649: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
6650: $fname=~s/\/home\/httpd\/html\/res/raw/;
1.373 albertel 6651: $fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
1.84 albertel 6652: $result="$fname\n";
6653: }
6654: } else {
6655: $result="not_found\n";
6656: }
6657: } else {
6658: $result="rejected\n";
6659: }
6660: return $result;
6661: }
1.287 foxr 6662: # Change the passwd of a unix user. The caller must have
6663: # first verified that the user is a loncapa user.
6664: #
6665: # Parameters:
6666: # user - Unix user name to change.
6667: # pass - New password for the user.
6668: # Returns:
6669: # ok - if success
6670: # other - Some meaningfule error message string.
6671: # NOTE:
6672: # invokes a setuid script to change the passwd.
6673: sub change_unix_password {
6674: my ($user, $pass) = @_;
6675:
6676: &Debug("change_unix_password");
6677: my $execdir=$perlvar{'lonDaemons'};
6678: &Debug("Opening lcpasswd pipeline");
6679: my $pf = IO::File->new("|$execdir/lcpasswd > "
6680: ."$perlvar{'lonDaemons'}"
6681: ."/logs/lcpasswd.log");
6682: print $pf "$user\n$pass\n$pass\n";
6683: close $pf;
6684: my $err = $?;
6685: return ($err < @passwderrors) ? $passwderrors[$err] :
6686: "pwchange_falure - unknown error";
6687:
6688:
6689: }
6690:
1.91 albertel 6691:
6692: sub make_passwd_file {
1.98 foxr 6693: my ($uname, $umode,$npass,$passfilename)=@_;
1.390 raeburn 6694: my $result="ok";
1.91 albertel 6695: if ($umode eq 'krb4' or $umode eq 'krb5') {
6696: {
6697: my $pf = IO::File->new(">$passfilename");
1.261 foxr 6698: if ($pf) {
6699: print $pf "$umode:$npass\n";
6700: } else {
6701: $result = "pass_file_failed_error";
6702: }
1.91 albertel 6703: }
6704: } elsif ($umode eq 'internal') {
6705: my $salt=time;
6706: $salt=substr($salt,6,2);
6707: my $ncpass=crypt($npass,$salt);
6708: {
6709: &Debug("Creating internal auth");
6710: my $pf = IO::File->new(">$passfilename");
1.261 foxr 6711: if($pf) {
6712: print $pf "internal:$ncpass\n";
6713: } else {
6714: $result = "pass_file_failed_error";
6715: }
1.91 albertel 6716: }
6717: } elsif ($umode eq 'localauth') {
6718: {
6719: my $pf = IO::File->new(">$passfilename");
1.261 foxr 6720: if($pf) {
6721: print $pf "localauth:$npass\n";
6722: } else {
6723: $result = "pass_file_failed_error";
6724: }
1.91 albertel 6725: }
6726: } elsif ($umode eq 'unix') {
6727: {
1.186 foxr 6728: #
6729: # Don't allow the creation of privileged accounts!!! that would
6730: # be real bad!!!
6731: #
6732: my $uid = getpwnam($uname);
6733: if((defined $uid) && ($uid == 0)) {
6734: &logthis(">>>Attempted to create privilged account blocked");
6735: return "no_priv_account_error\n";
6736: }
6737:
1.223 foxr 6738: my $execpath ="$perlvar{'lonDaemons'}/"."lcuseradd";
1.224 foxr 6739:
6740: my $lc_error_file = $execdir."/tmp/lcuseradd".$$.".status";
1.91 albertel 6741: {
6742: &Debug("Executing external: ".$execpath);
1.98 foxr 6743: &Debug("user = ".$uname.", Password =". $npass);
1.132 matthew 6744: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
1.91 albertel 6745: print $se "$uname\n";
6746: print $se "$npass\n";
6747: print $se "$npass\n";
1.223 foxr 6748: print $se "$lc_error_file\n"; # Status -> unique file.
1.97 foxr 6749: }
1.285 foxr 6750: if (-r $lc_error_file) {
6751: &Debug("Opening error file: $lc_error_file");
6752: my $error = IO::File->new("< $lc_error_file");
6753: my $useraddok = <$error>;
6754: $error->close;
6755: unlink($lc_error_file);
6756:
6757: chomp $useraddok;
6758:
6759: if($useraddok > 0) {
6760: my $error_text = &lcuseraddstrerror($useraddok);
6761: &logthis("Failed lcuseradd: $error_text");
1.390 raeburn 6762: $result = "lcuseradd_failed:$error_text";
1.285 foxr 6763: } else {
6764: my $pf = IO::File->new(">$passfilename");
6765: if($pf) {
6766: print $pf "unix:\n";
6767: } else {
6768: $result = "pass_file_failed_error";
6769: }
6770: }
1.224 foxr 6771: } else {
1.285 foxr 6772: &Debug("Could not locate lcuseradd error: $lc_error_file");
6773: $result="bug_lcuseradd_no_output_file";
1.91 albertel 6774: }
6775: }
6776: } elsif ($umode eq 'none') {
6777: {
1.223 foxr 6778: my $pf = IO::File->new("> $passfilename");
1.261 foxr 6779: if($pf) {
6780: print $pf "none:\n";
6781: } else {
6782: $result = "pass_file_failed_error";
6783: }
1.91 albertel 6784: }
6785: } else {
1.390 raeburn 6786: $result="auth_mode_error";
1.91 albertel 6787: }
6788: return $result;
1.121 albertel 6789: }
6790:
1.265 albertel 6791: sub convert_photo {
6792: my ($start,$dest)=@_;
6793: system("convert $start $dest");
6794: }
6795:
1.121 albertel 6796: sub sethost {
6797: my ($remotereq) = @_;
6798: my (undef,$hostid)=split(/:/,$remotereq);
1.322 albertel 6799: # ignore sethost if we are already correct
6800: if ($hostid eq $currenthostid) {
6801: return 'ok';
6802: }
6803:
1.121 albertel 6804: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
1.368 albertel 6805: if (&Apache::lonnet::get_host_ip($perlvar{'lonHostID'})
6806: eq &Apache::lonnet::get_host_ip($hostid)) {
1.200 matthew 6807: $currenthostid =$hostid;
1.369 albertel 6808: $currentdomainid=&Apache::lonnet::host_domain($hostid);
1.386 albertel 6809: &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
1.121 albertel 6810: } else {
6811: &logthis("Requested host id $hostid not an alias of ".
6812: $perlvar{'lonHostID'}." refusing connection");
6813: return 'unable_to_set';
6814: }
6815: return 'ok';
6816: }
6817:
6818: sub version {
6819: my ($userinput)=@_;
6820: $remoteVERSION=(split(/:/,$userinput))[1];
6821: return "version:$VERSION";
1.127 albertel 6822: }
1.178 foxr 6823:
1.200 matthew 6824:
1.61 harris41 6825: # ----------------------------------- POD (plain old documentation, CPAN style)
6826:
6827: =head1 NAME
6828:
6829: lond - "LON Daemon" Server (port "LOND" 5663)
6830:
6831: =head1 SYNOPSIS
6832:
1.74 harris41 6833: Usage: B<lond>
6834:
6835: Should only be run as user=www. This is a command-line script which
6836: is invoked by B<loncron>. There is no expectation that a typical user
6837: will manually start B<lond> from the command-line. (In other words,
6838: DO NOT START B<lond> YOURSELF.)
1.61 harris41 6839:
6840: =head1 DESCRIPTION
6841:
1.74 harris41 6842: There are two characteristics associated with the running of B<lond>,
6843: PROCESS MANAGEMENT (starting, stopping, handling child processes)
6844: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
6845: subscriptions, etc). These are described in two large
6846: sections below.
6847:
6848: B<PROCESS MANAGEMENT>
6849:
1.61 harris41 6850: Preforker - server who forks first. Runs as a daemon. HUPs.
6851: Uses IDEA encryption
6852:
1.74 harris41 6853: B<lond> forks off children processes that correspond to the other servers
6854: in the network. Management of these processes can be done at the
6855: parent process level or the child process level.
6856:
6857: B<logs/lond.log> is the location of log messages.
6858:
6859: The process management is now explained in terms of linux shell commands,
6860: subroutines internal to this code, and signal assignments:
6861:
6862: =over 4
6863:
6864: =item *
6865:
6866: PID is stored in B<logs/lond.pid>
6867:
6868: This is the process id number of the parent B<lond> process.
6869:
6870: =item *
6871:
6872: SIGTERM and SIGINT
6873:
6874: Parent signal assignment:
6875: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
6876:
6877: Child signal assignment:
6878: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
6879: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
6880: to restart a new child.)
6881:
6882: Command-line invocations:
6883: B<kill> B<-s> SIGTERM I<PID>
6884: B<kill> B<-s> SIGINT I<PID>
6885:
6886: Subroutine B<HUNTSMAN>:
6887: This is only invoked for the B<lond> parent I<PID>.
6888: This kills all the children, and then the parent.
6889: The B<lonc.pid> file is cleared.
6890:
6891: =item *
6892:
6893: SIGHUP
6894:
6895: Current bug:
6896: This signal can only be processed the first time
6897: on the parent process. Subsequent SIGHUP signals
6898: have no effect.
6899:
6900: Parent signal assignment:
6901: $SIG{HUP} = \&HUPSMAN;
6902:
6903: Child signal assignment:
6904: none (nothing happens)
6905:
6906: Command-line invocations:
6907: B<kill> B<-s> SIGHUP I<PID>
6908:
6909: Subroutine B<HUPSMAN>:
6910: This is only invoked for the B<lond> parent I<PID>,
6911: This kills all the children, and then the parent.
6912: The B<lond.pid> file is cleared.
6913:
6914: =item *
6915:
6916: SIGUSR1
6917:
6918: Parent signal assignment:
6919: $SIG{USR1} = \&USRMAN;
6920:
6921: Child signal assignment:
6922: $SIG{USR1}= \&logstatus;
6923:
6924: Command-line invocations:
6925: B<kill> B<-s> SIGUSR1 I<PID>
6926:
6927: Subroutine B<USRMAN>:
6928: When invoked for the B<lond> parent I<PID>,
6929: SIGUSR1 is sent to all the children, and the status of
6930: each connection is logged.
1.144 foxr 6931:
6932: =item *
6933:
6934: SIGUSR2
6935:
6936: Parent Signal assignment:
6937: $SIG{USR2} = \&UpdateHosts
6938:
6939: Child signal assignment:
6940: NONE
6941:
1.74 harris41 6942:
6943: =item *
6944:
6945: SIGCHLD
6946:
6947: Parent signal assignment:
6948: $SIG{CHLD} = \&REAPER;
6949:
6950: Child signal assignment:
6951: none
6952:
6953: Command-line invocations:
6954: B<kill> B<-s> SIGCHLD I<PID>
6955:
6956: Subroutine B<REAPER>:
6957: This is only invoked for the B<lond> parent I<PID>.
6958: Information pertaining to the child is removed.
6959: The socket port is cleaned up.
6960:
6961: =back
6962:
6963: B<SERVER-SIDE ACTIVITIES>
6964:
6965: Server-side information can be accepted in an encrypted or non-encrypted
6966: method.
6967:
6968: =over 4
6969:
6970: =item ping
6971:
6972: Query a client in the hosts.tab table; "Are you there?"
6973:
6974: =item pong
6975:
6976: Respond to a ping query.
6977:
6978: =item ekey
6979:
6980: Read in encrypted key, make cipher. Respond with a buildkey.
6981:
6982: =item load
6983:
6984: Respond with CPU load based on a computation upon /proc/loadavg.
6985:
6986: =item currentauth
6987:
6988: Reply with current authentication information (only over an
6989: encrypted channel).
6990:
6991: =item auth
6992:
6993: Only over an encrypted channel, reply as to whether a user's
6994: authentication information can be validated.
6995:
6996: =item passwd
6997:
6998: Allow for a password to be set.
6999:
7000: =item makeuser
7001:
7002: Make a user.
7003:
7004: =item passwd
7005:
7006: Allow for authentication mechanism and password to be changed.
7007:
7008: =item home
1.61 harris41 7009:
1.74 harris41 7010: Respond to a question "are you the home for a given user?"
7011:
7012: =item update
7013:
7014: Update contents of a subscribed resource.
7015:
7016: =item unsubscribe
7017:
7018: The server is unsubscribing from a resource.
7019:
7020: =item subscribe
7021:
7022: The server is subscribing to a resource.
7023:
7024: =item log
7025:
7026: Place in B<logs/lond.log>
7027:
7028: =item put
7029:
7030: stores hash in namespace
7031:
1.230 foxr 7032: =item rolesputy
1.74 harris41 7033:
7034: put a role into a user's environment
7035:
7036: =item get
7037:
7038: returns hash with keys from array
7039: reference filled in from namespace
7040:
7041: =item eget
7042:
7043: returns hash with keys from array
7044: reference filled in from namesp (encrypts the return communication)
7045:
7046: =item rolesget
7047:
7048: get a role from a user's environment
7049:
7050: =item del
7051:
7052: deletes keys out of array from namespace
7053:
7054: =item keys
7055:
7056: returns namespace keys
7057:
7058: =item dump
7059:
7060: dumps the complete (or key matching regexp) namespace into a hash
7061:
7062: =item store
7063:
7064: stores hash permanently
7065: for this url; hashref needs to be given and should be a \%hashname; the
7066: remaining args aren't required and if they aren't passed or are '' they will
7067: be derived from the ENV
7068:
7069: =item restore
7070:
7071: returns a hash for a given url
7072:
7073: =item querysend
7074:
7075: Tells client about the lonsql process that has been launched in response
7076: to a sent query.
7077:
7078: =item queryreply
7079:
7080: Accept information from lonsql and make appropriate storage in temporary
7081: file space.
7082:
7083: =item idput
7084:
7085: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
7086: for each student, defined perhaps by the institutional Registrar.)
7087:
7088: =item idget
7089:
7090: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
7091: for each student, defined perhaps by the institutional Registrar.)
7092:
7093: =item tmpput
7094:
7095: Accept and store information in temporary space.
7096:
7097: =item tmpget
7098:
7099: Send along temporarily stored information.
7100:
7101: =item ls
7102:
7103: List part of a user's directory.
7104:
1.135 foxr 7105: =item pushtable
7106:
7107: Pushes a file in /home/httpd/lonTab directory. Currently limited to:
7108: hosts.tab and domain.tab. The old file is copied to *.tab.backup but
7109: must be restored manually in case of a problem with the new table file.
7110: pushtable requires that the request be encrypted and validated via
7111: ValidateManager. The form of the command is:
7112: enc:pushtable tablename <tablecontents> \n
7113: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
7114: cleartext newline.
7115:
1.74 harris41 7116: =item Hanging up (exit or init)
7117:
7118: What to do when a client tells the server that they (the client)
7119: are leaving the network.
7120:
7121: =item unknown command
7122:
7123: If B<lond> is sent an unknown command (not in the list above),
7124: it replys to the client "unknown_cmd".
1.135 foxr 7125:
1.74 harris41 7126:
7127: =item UNKNOWN CLIENT
7128:
7129: If the anti-spoofing algorithm cannot verify the client,
7130: the client is rejected (with a "refused" message sent
7131: to the client, and the connection is closed.
7132:
7133: =back
1.61 harris41 7134:
7135: =head1 PREREQUISITES
7136:
7137: IO::Socket
7138: IO::File
7139: Apache::File
7140: POSIX
7141: Crypt::IDEA
7142: LWP::UserAgent()
7143: GDBM_File
7144: Authen::Krb4
1.91 albertel 7145: Authen::Krb5
1.61 harris41 7146:
7147: =head1 COREQUISITES
7148:
7149: =head1 OSNAMES
7150:
7151: linux
7152:
7153: =head1 SCRIPT CATEGORIES
7154:
7155: Server/Process
7156:
7157: =cut
1.409 foxr 7158:
7159:
7160: =pod
7161:
7162: =head1 LOG MESSAGES
7163:
7164: The messages below can be emitted in the lond log. This log is located
7165: in ~httpd/perl/logs/lond.log Many log messages have HTML encapsulation
7166: to provide coloring if examined from inside a web page. Some do not.
7167: Where color is used, the colors are; Red for sometihhng to get excited
7168: about and to follow up on. Yellow for something to keep an eye on to
7169: be sure it does not get worse, Green,and Blue for informational items.
7170:
7171: In the discussions below, sometimes reference is made to ~httpd
7172: when describing file locations. There isn't really an httpd
7173: user, however there is an httpd directory that gets installed in the
7174: place that user home directories go. On linux, this is usually
7175: (always?) /home/httpd.
7176:
7177:
7178: Some messages are colorless. These are usually (not always)
7179: Green/Blue color level messages.
7180:
7181: =over 2
7182:
7183: =item (Red) LocalConnection rejecting non local: <ip> ne 127.0.0.1
7184:
7185: A local connection negotiation was attempted by
7186: a host whose IP address was not 127.0.0.1.
7187: The socket is closed and the child will exit.
7188: lond has three ways to establish an encyrption
7189: key with a client:
7190:
7191: =over 2
7192:
7193: =item local
7194:
7195: The key is written and read from a file.
7196: This is only valid for connections from localhost.
7197:
7198: =item insecure
7199:
7200: The key is generated by the server and
7201: transmitted to the client.
7202:
7203: =item ssl (secure)
7204:
7205: An ssl connection is negotiated with the client,
7206: the key is generated by the server and sent to the
7207: client across this ssl connection before the
7208: ssl connectionis terminated and clear text
7209: transmission resumes.
7210:
7211: =back
7212:
7213: =item (Red) LocalConnection: caller is insane! init = <init> and type = <type>
7214:
7215: The client is local but has not sent an initialization
7216: string that is the literal "init:local" The connection
7217: is closed and the child exits.
7218:
7219: =item Red CRITICAL Can't get key file <error>
7220:
7221: SSL key negotiation is being attempted but the call to
7222: lonssl::KeyFile failed. This usually means that the
7223: configuration file is not correctly defining or protecting
7224: the directories/files lonCertificateDirectory or
7225: lonnetPrivateKey
7226: <error> is a string that describes the reason that
7227: the key file could not be located.
7228:
7229: =item (Red) CRITICAL Can't get certificates <error>
7230:
7231: SSL key negotiation failed because we were not able to retrives our certificate
7232: or the CA's certificate in the call to lonssl::CertificateFile
7233: <error> is the textual reason this failed. Usual reasons:
7234:
7235: =over 2
7236:
7237: =item Apache config file for loncapa incorrect:
7238:
7239: one of the variables
7240: lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate
7241: undefined or incorrect
7242:
7243: =item Permission error:
7244:
7245: The directory pointed to by lonCertificateDirectory is not readable by lond
7246:
7247: =item Permission error:
7248:
7249: Files in the directory pointed to by lonCertificateDirectory are not readable by lond.
7250:
7251: =item Installation error:
7252:
7253: Either the certificate authority file or the certificate have not
7254: been installed in lonCertificateDirectory.
7255:
7256: =item (Red) CRITICAL SSL Socket promotion failed: <err>
7257:
7258: The promotion of the connection from plaintext to SSL failed
7259: <err> is the reason for the failure. There are two
7260: system calls involved in the promotion (one of which failed),
7261: a dup to produce
7262: a second fd on the raw socket over which the encrypted data
7263: will flow and IO::SOcket::SSL->new_from_fd which creates
7264: the SSL connection on the duped fd.
7265:
7266: =item (Blue) WARNING client did not respond to challenge
7267:
7268: This occurs on an insecure (non SSL) connection negotiation request.
7269: lond generates some number from the time, the PID and sends it to
7270: the client. The client must respond by echoing this information back.
7271: If the client does not do so, that's a violation of the challenge
7272: protocols and the connection will be failed.
7273:
7274: =item (Red) No manager table. Nobody can manage!!
7275:
7276: lond has the concept of privileged hosts that
7277: can perform remote management function such
7278: as update the hosts.tab. The manager hosts
7279: are described in the
7280: ~httpd/lonTabs/managers.tab file.
7281: this message is logged if this file is missing.
7282:
7283:
7284: =item (Green) Registering manager <dnsname> as <cluster_name> with <ipaddress>
7285:
7286: Reports the successful parse and registration
7287: of a specific manager.
7288:
7289: =item Green existing host <clustername:dnsname>
7290:
7291: The manager host is already defined in the hosts.tab
7292: the information in that table, rather than the info in the
7293: manager table will be used to determine the manager's ip.
7294:
7295: =item (Red) Unable to craete <filename>
7296:
7297: lond has been asked to create new versions of an administrative
7298: file (by a manager). When this is done, the new file is created
7299: in a temp file and then renamed into place so that there are always
7300: usable administrative files, even if the update fails. This failure
7301: message means that the temp file could not be created.
7302: The update is abandoned, and the old file is available for use.
7303:
7304: =item (Green) CopyFile from <oldname> to <newname> failed
7305:
7306: In an update of administrative files, the copy of the existing file to a
7307: backup file failed. The installation of the new file may still succeed,
7308: but there will not be a back up file to rever to (this should probably
7309: be yellow).
7310:
7311: =item (Green) Pushfile: backed up <oldname> to <newname>
7312:
7313: See above, the backup of the old administrative file succeeded.
7314:
7315: =item (Red) Pushfile: Unable to install <filename> <reason>
7316:
7317: The new administrative file could not be installed. In this case,
7318: the old administrative file is still in use.
7319:
7320: =item (Green) Installed new < filename>.
7321:
7322: The new administrative file was successfullly installed.
7323:
7324: =item (Red) Reinitializing lond pid=<pid>
7325:
7326: The lonc child process <pid> will be sent a USR2
7327: signal.
7328:
7329: =item (Red) Reinitializing self
7330:
7331: We've been asked to re-read our administrative files,and
7332: are doing so.
7333:
7334: =item (Yellow) error:Invalid process identifier <ident>
7335:
7336: A reinit command was received, but the target part of the
7337: command was not valid. It must be either
7338: 'lond' or 'lonc' but was <ident>
7339:
7340: =item (Green) isValideditCommand checking: Command = <command> Key = <key> newline = <newline>
7341:
7342: Checking to see if lond has been handed a valid edit
7343: command. It is possible the edit command is not valid
7344: in that case there are no log messages to indicate that.
7345:
7346: =item Result of password change for <username> pwchange_success
7347:
7348: The password for <username> was
7349: successfully changed.
7350:
7351: =item Unable to open <user> passwd to change password
7352:
7353: Could not rewrite the
7354: internal password file for a user
7355:
7356: =item Result of password change for <user> : <result>
7357:
7358: A unix password change for <user> was attempted
7359: and the pipe returned <result>
7360:
7361: =item LWP GET: <message> for <fname> (<remoteurl>)
7362:
7363: The lightweight process fetch for a resource failed
7364: with <message> the local filename that should
7365: have existed/been created was <fname> the
7366: corresponding URI: <remoteurl> This is emitted in several
7367: places.
7368:
7369: =item Unable to move <transname> to <destname>
7370:
7371: From fetch_user_file_handler - the user file was replicated but could not
7372: be mv'd to its final location.
7373:
7374: =item Looking for <domain> <username>
7375:
7376: From user_has_session_handler - This should be a Debug call instead
7377: it indicates lond is about to check whether the specified user has a
7378: session active on the specified domain on the local host.
7379:
7380: =item Client <ip> (<name>) hanging up: <input>
7381:
7382: lond has been asked to exit by its client. The <ip> and <name> identify the
7383: client systemand <input> is the full exit command sent to the server.
7384:
7385: =item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].
7386:
7387: A lond child terminated. NOte that this termination can also occur when the
7388: child receives the QUIT or DIE signals. <pid> is the process id of the child,
7389: <hostname> the host lond is working for, and <message> the reason the child died
7390: to the best of our ability to get it (I would guess that any numeric value
7391: represents and errno value). This is immediately followed by
7392:
7393: =item Famous last words: Catching exception - <log>
7394:
7395: Where log is some recent information about the state of the child.
7396:
7397: =item Red CRITICAL: TIME OUT <pid>
7398:
7399: Some timeout occured for server <pid>. THis is normally a timeout on an LWP
7400: doing an HTTP::GET.
7401:
7402: =item child <pid> died
7403:
7404: The reaper caught a SIGCHILD for the lond child process <pid>
7405: This should be modified to also display the IP of the dying child
7406: $children{$pid}
7407:
7408: =item Unknown child 0 died
7409: A child died but the wait for it returned a pid of zero which really should not
7410: ever happen.
7411:
7412: =item Child <which> - <pid> looks like we missed it's death
7413:
7414: When a sigchild is received, the reaper process checks all children to see if they are
7415: alive. If children are dying quite quickly, the lack of signal queuing can mean
7416: that a signal hearalds the death of more than one child. If so this message indicates
7417: which other one died. <which> is the ip of a dead child
7418:
7419: =item Free socket: <shutdownretval>
7420:
7421: The HUNTSMAN sub was called due to a SIGINT in a child process. The socket is being shutdown.
7422: for whatever reason, <shutdownretval> is printed but in fact shutdown() is not documented
7423: to return anything. This is followed by:
7424:
7425: =item Red CRITICAL: Shutting down
7426:
7427: Just prior to exit.
7428:
7429: =item Free socket: <shutdownretval>
7430:
7431: The HUPSMAN sub was called due to a SIGHUP. all children get killsed, and lond execs itself.
7432: This is followed by:
7433:
7434: =item (Red) CRITICAL: Restarting
7435:
7436: lond is about to exec itself to restart.
7437:
7438: =item (Blue) Updating connections
7439:
7440: (In response to a USR2). All the children (except the one for localhost)
7441: are about to be killed, the hosts tab reread, and Apache reloaded via apachereload.
7442:
7443: =item (Blue) UpdateHosts killing child <pid> for ip <ip>
7444:
7445: Due to USR2 as above.
7446:
7447: =item (Green) keeping child for ip <ip> (pid = <pid>)
7448:
7449: In response to USR2 as above, the child indicated is not being restarted because
7450: it's assumed that we'll always need a child for the localhost.
7451:
7452:
7453: =item Going to check on the children
7454:
7455: Parent is about to check on the health of the child processes.
7456: Note that this is in response to a USR1 sent to the parent lond.
7457: there may be one or more of the next two messages:
7458:
7459: =item <pid> is dead
7460:
7461: A child that we have in our child hash as alive has evidently died.
7462:
7463: =item Child <pid> did not respond
7464:
7465: In the health check the child <pid> did not update/produce a pid_.txt
7466: file when sent it's USR1 signal. That process is killed with a 9 signal, as it's
7467: assumed to be hung in some un-fixable way.
7468:
7469: =item Finished checking children
7470:
7471: Master processs's USR1 processing is cojmplete.
7472:
7473: =item (Red) CRITICAL: ------- Starting ------
7474:
7475: (There are more '-'s on either side). Lond has forked itself off to
7476: form a new session and is about to start actual initialization.
7477:
7478: =item (Green) Attempting to start child (<client>)
7479:
7480: Started a new child process for <client>. Client is IO::Socket object
7481: connected to the child. This was as a result of a TCP/IP connection from a client.
7482:
7483: =item Unable to determine who caller was, getpeername returned nothing
7484:
7485: In child process initialization. either getpeername returned undef or
7486: a zero sized object was returned. Processing continues, but in my opinion,
7487: this should be cause for the child to exit.
7488:
7489: =item Unable to determine clientip
7490:
7491: In child process initialization. The peer address from getpeername was not defined.
7492: The client address is stored as "Unavailable" and processing continues.
7493:
7494: =item (Yellow) INFO: Connection <ip> <name> connection type = <type>
7495:
7496: In child initialization. A good connectionw as received from <ip>.
7497:
7498: =over 2
7499:
7500: =item <name>
7501:
7502: is the name of the client from hosts.tab.
7503:
7504: =item <type>
7505:
7506: Is the connection type which is either
7507:
7508: =over 2
7509:
7510: =item manager
7511:
7512: The connection is from a manager node, not in hosts.tab
7513:
7514: =item client
7515:
7516: the connection is from a non-manager in the hosts.tab
7517:
7518: =item both
7519:
7520: The connection is from a manager in the hosts.tab.
7521:
7522: =back
7523:
7524: =back
7525:
7526: =item (Blue) Certificates not installed -- trying insecure auth
7527:
7528: One of the certificate file, key file or
7529: certificate authority file could not be found for a client attempting
7530: SSL connection intiation. COnnection will be attemptied in in-secure mode.
7531: (this would be a system with an up to date lond that has not gotten a
7532: certificate from us).
7533:
7534: =item (Green) Successful local authentication
7535:
7536: A local connection successfully negotiated the encryption key.
7537: In this case the IDEA key is in a file (that is hopefully well protected).
7538:
7539: =item (Green) Successful ssl authentication with <client>
7540:
7541: The client (<client> is the peer's name in hosts.tab), has successfully
7542: negotiated an SSL connection with this child process.
7543:
7544: =item (Green) Successful insecure authentication with <client>
7545:
7546:
7547: The client has successfully negotiated an insecure connection withthe child process.
7548:
7549: =item (Yellow) Attempted insecure connection disallowed
7550:
7551: The client attempted and failed to successfully negotiate a successful insecure
7552: connection. This can happen either because the variable londAllowInsecure is false
7553: or undefined, or becuse the child did not successfully echo back the challenge
7554: string.
7555:
7556:
7557: =back
7558:
7559:
7560: =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