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