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