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