Annotation of loncom/lond, revision 1.178.2.13
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 www 4: #
1.178.2.9 foxr 5: # $Id: lond,v 1.178.2.8 2004/03/16 10:52:30 foxr Exp $
1.60 www 6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
1.167 foxr 13: # the Free Software Foundation; either version 2 of the License, or
1.60 www 14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
1.178.2.1 foxr 23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
1.60 www 24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
1.161 foxr 27:
28:
1.60 www 29: # http://www.lon-capa.org/
30: #
1.54 harris41 31:
1.134 albertel 32: use strict;
1.80 harris41 33: use lib '/home/httpd/lib/perl/';
34: use LONCAPA::Configuration;
35:
1.1 albertel 36: use IO::Socket;
37: use IO::File;
1.126 albertel 38: #use Apache::File;
1.1 albertel 39: use Symbol;
40: use POSIX;
41: use Crypt::IDEA;
42: use LWP::UserAgent();
1.3 www 43: use GDBM_File;
44: use Authen::Krb4;
1.91 albertel 45: use Authen::Krb5;
1.49 albertel 46: use lib '/home/httpd/lib/perl/';
47: use localauth;
1.143 foxr 48: use File::Copy;
1.169 foxr 49: use LONCAPA::ConfigFileEdit;
1.1 albertel 50:
1.178.2.2 foxr 51: my $DEBUG = 1; # Non zero to enable debug log entries.
1.77 foxr 52:
1.57 www 53: my $status='';
54: my $lastlog='';
55:
1.178.2.9 foxr 56: my $VERSION='$Revision: 1.178.2.8 $'; #' stupid emacs
1.121 albertel 57: my $remoteVERSION;
1.115 albertel 58: my $currenthostid;
59: my $currentdomainid;
1.134 albertel 60:
61: my $client;
1.140 foxr 62: my $clientip;
1.161 foxr 63: my $clientname;
1.140 foxr 64:
1.178.2.1 foxr 65: my $cipher; # Cipher key negotiated with client.
66: my $tmpsnum = 0;; # Id of tmpputs.
67:
1.134 albertel 68: my $server;
69: my $thisserver;
70:
1.178.2.1 foxr 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: }
1.178.2.8 foxr 164: #
1.178.2.9 foxr 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;
1.178.2.10 foxr 185:
1.178.2.9 foxr 186: # Filter out any whitespace in the domain name:
1.178.2.10 foxr 187:
1.178.2.9 foxr 188: $domain =~ s/\W//g;
1.178.2.10 foxr 189:
1.178.2.9 foxr 190: # We have enough to go on to tie the hash:
1.178.2.10 foxr 191:
192: my $UserTopDir = $perlvar{'lonUsersDir'};
1.178.2.9 foxr 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");
1.178.2.10 foxr 199: if($logFh) {
1.178.2.9 foxr 200: my $TimeStamp = time;
201: my ($loghead, $logtail) = @_;
1.178.2.10 foxr 202: print $logFh "$loghead:$TimeStamp:$logtail\n";
1.178.2.9 foxr 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
1.178.2.8 foxr 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: #
1.178.2.9 foxr 231: sub TieUserHash {
1.178.2.10 foxr 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);
1.178.2.13! foxr 240:
1.178.2.10 foxr 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;
1.178.2.12 foxr 257: if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
1.178.2.10 foxr 258: $how, 0640)) {
259: return \%hash;
260: }
261: else {
262: return undef;
263: }
264:
1.178.2.8 foxr 265: }
1.178.2.1 foxr 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 {
1.178.2.4 albertel 293: my $input = shift;
294: my $output = '';
1.178.2.1 foxr 295:
296:
1.178.2.4 albertel 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: }
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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#
1.178.2.1 foxr 344:
1.178.2.4 albertel 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:
1.178.2.1 foxr 359:
1.178.2.4 albertel 360: my @entry = ($Procedure, $MustEncode, $ClientTypeMask);
1.178.2.1 foxr 361:
1.178.2.4 albertel 362: $Dispatcher{$RequestName} = \@entry;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 387: my $cmd = shift;
388: my $tail = shift;
389: my $client = shift;
1.178.2.1 foxr 390:
1.178.2.4 albertel 391: Reply( $client,"$currenthostid\n","$cmd:$tail");
1.178.2.1 foxr 392:
1.178.2.4 albertel 393: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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");
1.178.2.1 foxr 458:
1.178.2.4 albertel 459: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 482: my $cmd = shift;
483: my $tail = shift;
484: my $replyfd = shift;
1.178.2.1 foxr 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:
1.178.2.4 albertel 489: my $loadavg;
490: my $loadfile=IO::File->new('/proc/loadavg');
1.178.2.1 foxr 491:
1.178.2.4 albertel 492: $loadavg=<$loadfile>;
493: $loadavg =~ s/\s.*//g; # Extract the first field only.
1.178.2.1 foxr 494:
1.178.2.4 albertel 495: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
1.178.2.1 foxr 496:
1.178.2.4 albertel 497: Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");
1.178.2.1 foxr 498:
1.178.2.4 albertel 499: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 525: my $cmd = shift;
526: my $tail = shift;
527: my $replyfd = shift;
1.178.2.1 foxr 528:
1.178.2.4 albertel 529: my $userloadpercent=&userload();
530: Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
531:
532: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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 {
1.178.2.8 foxr 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);
1.178.2.4 albertel 574: }
1.178.2.1 foxr 575:
1.178.2.4 albertel 576: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 595: my $cmd = shift;
596: my $tail = shift;
597: my $client = shift;
1.178.2.1 foxr 598:
1.178.2.4 albertel 599: my $userinput = "$cmd:$tail";
1.178.2.1 foxr 600:
1.178.2.4 albertel 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).
1.178.2.1 foxr 604:
1.178.2.4 albertel 605: my $cert = GetCertificate($userinput);
606: if(ValidManager($cert)) {
1.178.2.1 foxr 607:
1.178.2.4 albertel 608: # Now presumably we have the bona fides of both the peer host and the
609: # process making the request.
1.178.2.1 foxr 610:
1.178.2.4 albertel 611: my $reply = PushFile($userinput);
612: Reply($client, "$reply\n", $userinput);
1.178.2.1 foxr 613:
1.178.2.4 albertel 614: } else {
615: Failure( $client, "refused\n", $userinput);
616: }
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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.
1.178.2.4 albertel 710: # - user - The person tailoring LonCAPA can supply a user authentication
711: # mechanism that is per system.
1.178.2.1 foxr 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 {
1.178.2.4 albertel 725: my $cmd = shift;
726: my $tail = shift;
727: my $client = shift;
1.178.2.10 foxr 728:
1.178.2.4 albertel 729: # Regenerate the full input line
1.178.2.10 foxr 730:
1.178.2.4 albertel 731: my $userinput = $cmd.":".$tail;
1.178.2.10 foxr 732:
1.178.2.4 albertel 733: # udom - User's domain.
734: # uname - Username.
735: # upass - User's password.
1.178.2.10 foxr 736:
1.178.2.4 albertel 737: my ($udom,$uname,$upass)=split(/:/,$tail);
738: Debug(" Authenticate domain = $udom, user = $uname, password = $upass");
739: chomp($upass);
740: $upass=unescape($upass);
741:
1.178.2.13! foxr 742: my $pwdcorrect = ValidateUser($udom, $uname, $upass);
! 743: if($pwdcorrect) {
! 744: Reply( $client, "authorized\n", $userinput);
1.178.2.4 albertel 745: #
1.178.2.13! foxr 746: # Bad credentials: Failed to authorize
1.178.2.4 albertel 747: #
748: } else {
1.178.2.8 foxr 749: Failure( $client, "non_authorized\n", $userinput);
1.178.2.4 albertel 750: }
1.178.2.13! foxr 751:
1.178.2.4 albertel 752: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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");
1.178.2.13! foxr 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:
1.178.2.4 albertel 803: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
804: if ($howpwd eq 'internal') {
805: &Debug("internal auth");
1.178.2.13! foxr 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);
1.178.2.4 albertel 813: } else {
1.178.2.13! foxr 814: &logthis("Unable to open $uname passwd "
! 815: ."to change password");
! 816: Failure( $client, "non_authorized\n",$userinput);
1.178.2.4 albertel 817: }
818: } elsif ($howpwd eq 'unix') {
819: # Unix means we have to access /etc/password
820: &Debug("auth is unix");
1.178.2.13! foxr 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);
1.178.2.4 albertel 833: } else {
1.178.2.8 foxr 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: #
1.178.2.4 albertel 838: Reply( $client, "auth_mode_error\n", $userinput);
839: }
1.178.2.13! foxr 840:
! 841: }
! 842: else {
1.178.2.8 foxr 843: Reply( $client, "non_authorized\n", $userinput);
1.178.2.4 albertel 844: }
1.178.2.13! foxr 845:
1.178.2.4 albertel 846: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 867: my $cmd = shift;
868: my $tail = shift;
869: my $client = shift;
870:
871: my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
1.178.2.8 foxr 872: my $userinput = $cmd.":".$tail; # Reconstruct the full request line.
873:
1.178.2.4 albertel 874: &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);
1.178.2.8 foxr 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: }
1.178.2.4 albertel 897: }
898: }
1.178.2.8 foxr 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: }
1.178.2.4 albertel 905: }
1.178.2.8 foxr 906: umask($oldumask);
907: } else {
908: Failure($client, "not_right_domain\n",
909: $userinput); # Even if we are multihomed.
910:
1.178.2.4 albertel 911: }
912: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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 {
1.178.2.8 foxr 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: }
1.178.2.4 albertel 962: }
963: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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);
1.178.2.8 foxr 992: my $passfile = PasswordPath($udom, $uname);
993: if($passfile) {
1.178.2.4 albertel 994: Reply( $client, "found\n", $userinput);
995: } else {
996: Failure($client, "not_found\n", $userinput);
997: }
998: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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
1.178.2.8 foxr 1142: # represents the user's session id. Once it is forged does this allow too much
1143: # access??
1.178.2.1 foxr 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 {
1.178.2.8 foxr 1153: my $cmd = shift;
1154: my $tail = shift;
1155: my $client = shift;
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.1 foxr 1200: }
1201: RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);
1202:
1.178.2.13! foxr 1203: # Subscribe to a resource
1.178.2.1 foxr 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 {
1.178.2.4 albertel 1214: my $cmd = shift;
1215: my $tail = shift;
1216: my $client = shift;
1217: my $userinput = "$cmd:$tail";
1.178.2.1 foxr 1218:
1.178.2.4 albertel 1219: Reply( $client, &subscribe($userinput,$clientip), $userinput);
1220:
1221: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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 {
1.178.2.8 foxr 1277: Failure($client, "error: ".($!+0)." IO::File->new Failed "
1.178.2.4 albertel 1278: ."while attempting log\n",
1279: $userinput);
1280: }
1.178.2.1 foxr 1281:
1.178.2.4 albertel 1282: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 1300: my $cmd = shift;
1301: my $tail = shift;
1302: my $client = shift;
1303: my $userinput = "$cmd:$tail";
1.178.2.10 foxr 1304:
1.178.2.4 albertel 1305: my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
1306: if ($namespace ne 'roles') {
1.178.2.10 foxr 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 {
1.178.2.8 foxr 1328: Failure( $client, "refused\n", $userinput);
1.178.2.10 foxr 1329: }
1.178.2.8 foxr 1330:
1.178.2.10 foxr 1331: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 1351: my $cmd = shift;
1352: my $tail = shift;
1353: my $client = shift;
1.178.2.7 foxr 1354: my $userinput = "$cmd:$tail";
1.178.2.4 albertel 1355:
1356: my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
1357: if ($namespace ne 'roles') {
1.178.2.8 foxr 1358: chomp($what);
1.178.2.9 foxr 1359: my $hashref = TieUserHash($udom, $uname,
1.178.2.10 foxr 1360: $namespace, &GDBM_WRCREAT(),
1361: "P",$what);
1.178.2.8 foxr 1362: if ($hashref) {
1.178.2.10 foxr 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: }
1.178.2.8 foxr 1385:
1.178.2.4 albertel 1386: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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);
1.178.2.9 foxr 1420: my $hashref = TieUserHash($udom, $uname, $namespace,
1.178.2.10 foxr 1421: &GDBM_WRCREAT(), "P",
1422: "$exedom:$exeuser:$what");
1.178.2.4 albertel 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.
1.178.2.8 foxr 1428: if ($hashref) {
1429: my @pairs=split(/\&/,$what);
1.178.2.4 albertel 1430: foreach my $pair (@pairs) {
1431: my ($key,$value)=split(/=/,$pair);
1.178.2.8 foxr 1432: &ManagePermissions($key, $udom, $uname,
1433: &GetAuthType( $udom, $uname));
1434: $hashref->{$key}=$value;
1.178.2.4 albertel 1435: }
1.178.2.8 foxr 1436: if (untie($hashref)) {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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);
1.178.2.9 foxr 1477: my $hashref = TieUserHash($udom, $uname, $namespace,
1.178.2.10 foxr 1478: &GDBM_WRCREAT(), "D",
1479: "$exedom:$exeuser:$what");
1480:
1.178.2.8 foxr 1481: if ($hashref) {
1.178.2.10 foxr 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);
1.178.2.4 albertel 1489: } else {
1.178.2.10 foxr 1490: Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
1491: "while attempting rolesdel\n", $userinput);
1.178.2.4 albertel 1492: }
1.178.2.10 foxr 1493: } else {
1.178.2.8 foxr 1494: Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
1.178.2.4 albertel 1495: "while attempting rolesdel\n", $userinput);
1.178.2.10 foxr 1496: }
1.178.2.4 albertel 1497:
1498: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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);
1.178.2.9 foxr 1529: my $hashref = TieUserHash($udom, $uname, $namespace,
1.178.2.10 foxr 1530: &GDBM_READER());
1.178.2.8 foxr 1531: if ($hashref) {
1532: my @queries=split(/\&/,$what);
1533: my $qresult='';
1.178.2.10 foxr 1534:
1.178.2.4 albertel 1535: for (my $i=0;$i<=$#queries;$i++) {
1.178.2.8 foxr 1536: $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.
1.178.2.4 albertel 1537: }
1.178.2.8 foxr 1538: $qresult=~s/\&$//; # Remove trailing & from last lookup.
1539: if (untie(%$hashref)) {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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);
1.178.2.9 foxr 1584: my $hashref = TieUserHash($udom, $uname, $namespace,
1.178.2.8 foxr 1585: &GDBM_READER());
1586: if ($hashref) {
1587: my @queries=split(/\&/,$what);
1588: my $qresult='';
1.178.2.4 albertel 1589: for (my $i=0;$i<=$#queries;$i++) {
1.178.2.8 foxr 1590: $qresult.="$hashref->{$queries[$i]}&";
1.178.2.4 albertel 1591: }
1.178.2.8 foxr 1592: if (untie(%$hashref)) {
1.178.2.4 albertel 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) {
1.178.2.10 foxr 1599: $encqresult.= unpack("H16",
1600: $cipher->encrypt(substr($qresult,
1601: $encidx,
1602: 8)));
1.178.2.4 albertel 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;
1.178.2.1 foxr 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: #
1.178.2.6 foxr 1639:
1640: sub DeleteProfileEntry {
1.178.2.4 albertel 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);
1.178.2.9 foxr 1648: my $hashref = TieUserHash($udom, $uname, $namespace,
1.178.2.8 foxr 1649: &GDBM_WRCREAT(),
1650: "D",$what);
1651: if ($hashref) {
1652: my @keys=split(/\&/,$what);
1.178.2.4 albertel 1653: foreach my $key (@keys) {
1.178.2.8 foxr 1654: delete($hashref->{$key});
1.178.2.4 albertel 1655: }
1.178.2.8 foxr 1656: if (untie(%$hashref)) {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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='';
1.178.2.9 foxr 1692: my $hashref = TieUserHash($udom, $uname, $namespace,
1.178.2.8 foxr 1693: &GDBM_READER());
1694: if ($hashref) {
1695: foreach my $key (keys %$hashref) {
1.178.2.4 albertel 1696: $qresult.="$key&";
1697: }
1.178.2.8 foxr 1698: if (untie(%$hashref)) {
1.178.2.4 albertel 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: }
1.178.2.1 foxr 1709:
1.178.2.4 albertel 1710: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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);
1.178.2.9 foxr 1739: my $hashref = TieUserHash($udom, $uname, $namespace,
1.178.2.8 foxr 1740: &GDBM_READER());
1741: if ($hashref) {
1.178.2.4 albertel 1742: # Structure of %data:
1743: # $data{$symb}->{$parameter}=$value;
1744: # $data{$symb}->{'v.'.$parameter}=$version;
1745: # since $parameter will be unescaped, we do not
1.178.2.8 foxr 1746: # have to worry about silly parameter names...
1.178.2.10 foxr 1747:
1.178.2.8 foxr 1748: my $qresult='';
1.178.2.4 albertel 1749: my %data = (); # A hash of anonymous hashes..
1.178.2.8 foxr 1750: while (my ($key,$value) = each(%$hashref)) {
1.178.2.4 albertel 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: }
1.178.2.8 foxr 1759: if (untie(%$hashref)) {
1.178.2.4 albertel 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: }
1.178.2.1 foxr 1779:
1.178.2.4 albertel 1780: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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: }
1.178.2.9 foxr 1820: my $hashref =TieUserHash($udom, $uname, $namespace,
1.178.2.8 foxr 1821: &GDBM_READER());
1822: if ($hashref) {
1823: my $qresult='';
1824: while (my ($key,$value) = each(%$hashref)) {
1.178.2.4 albertel 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: }
1.178.2.8 foxr 1834: if (untie(%$hashref)) {
1.178.2.4 albertel 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: }
1.178.2.1 foxr 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 {
1.178.2.4 albertel 1869: my $cmd = shift;
1870: my $tail = shift;
1871: my $client = shift;
1.178.2.1 foxr 1872:
1.178.2.4 albertel 1873: my $userinput = "$cmd:$tail";
1.178.2.1 foxr 1874:
1.178.2.4 albertel 1875: my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);
1876: if ($namespace ne 'roles') {
1.178.2.8 foxr 1877:
1.178.2.4 albertel 1878: chomp($what);
1879: my @pairs=split(/\&/,$what);
1.178.2.9 foxr 1880: my $hashref = TieUserHash($udom, $uname, $namespace,
1.178.2.8 foxr 1881: &GDBM_WRCREAT(), "P",
1882: "$rid:$what");
1883: if ($hashref) {
1884: my $now = time;
1885: my @previouskeys=split(/&/,$hashref->{"keys:$rid"});
1.178.2.4 albertel 1886: my $key;
1.178.2.8 foxr 1887: $hashref->{"version:$rid"}++;
1888: my $version=$hashref->{"version:$rid"};
1.178.2.4 albertel 1889: my $allkeys='';
1890: foreach my $pair (@pairs) {
1891: my ($key,$value)=split(/=/,$pair);
1892: $allkeys.=$key.':';
1.178.2.8 foxr 1893: $hashref->{"$version:$rid:$key"}=$value;
1.178.2.4 albertel 1894: }
1.178.2.8 foxr 1895: $hashref->{"$version:$rid:timestamp"}=$now;
1.178.2.4 albertel 1896: $allkeys.='timestamp';
1.178.2.8 foxr 1897: $hashref->{"$version:keys:$rid"}=$allkeys;
1898: if (untie($hashref)) {
1.178.2.4 albertel 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);
1.178.2.1 foxr 1910: }
1911:
1.178.2.4 albertel 1912: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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: }
1.178.2.1 foxr 1970:
1.178.2.4 albertel 1971: return 1;
1.178.2.1 foxr 1972:
1973:
1974: }
1.178.2.6 foxr 1975: RegisterHandler("restore", \&RestoreHandler, 0,1,0);
1.178.2.1 foxr 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 {
1.178.2.4 albertel 1996: my $cmd = shift;
1997: my $tail = shift;
1998: my $client = shift;
1999:
2000: my $userinput = "$cmd:$tail";
1.178.2.1 foxr 2001:
1.178.2.4 albertel 2002: my ($cdom,$cnum,$newpost)=split(/\:/,$tail);
2003: &chatadd($cdom,$cnum,$newpost);
2004: Reply($client, "ok\n", $userinput);
1.178.2.1 foxr 2005:
1.178.2.4 albertel 2006: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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);
1.178.2.1 foxr 2040:
2041:
1.178.2.4 albertel 2042: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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: }
1.178.2.1 foxr 2129:
2130:
1.178.2.4 albertel 2131: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 2153: my $cmd = shift;
2154: my $tail = shift;
2155: my $client = shift;
1.178.2.1 foxr 2156:
1.178.2.4 albertel 2157: my $userinput = "$cmd:$tail";
2158:
1.178.2.10 foxr 2159: my ($udom, $what) = split(/:/, $tail);
1.178.2.4 albertel 2160: chomp($what);
2161: my $now=time;
2162: my @pairs=split(/\&/,$what);
1.178.2.9 foxr 2163:
2164: my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
2165: if ($hashref) {
1.178.2.4 albertel 2166: foreach my $pair (@pairs) {
2167: my ($key,$value)=split(/=/,$pair);
1.178.2.9 foxr 2168: $hashref->{$key}=$value.':'.$now;
1.178.2.4 albertel 2169: }
1.178.2.9 foxr 2170: if (untie(%$hashref)) {
1.178.2.4 albertel 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;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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='';
1.178.2.9 foxr 2225:
2226: my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
2227: if ($hashref) {
2228: while (my ($key,$value) = each(%$hashref)) {
1.178.2.4 albertel 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: }
1.178.2.9 foxr 2242: if (untie(%$hashref)) {
1.178.2.4 albertel 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: }
1.178.2.1 foxr 2253:
2254:
1.178.2.4 albertel 2255: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 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);
1.178.2.9 foxr 2284: my $hashref = TieDomainHash($udom, "ids", &GDBM_WRCREAT(),
2285: "P", $what);
2286: if ($hashref) {
1.178.2.4 albertel 2287: foreach my $pair (@pairs) {
2288: my ($key,$value)=split(/=/,$pair);
1.178.2.9 foxr 2289: $hashref->{$key}=$value;
1.178.2.4 albertel 2290: }
1.178.2.9 foxr 2291: if (untie(%$hashref)) {
1.178.2.4 albertel 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);
1.178.2.1 foxr 2300: }
2301:
1.178.2.4 albertel 2302: return 1;
1.178.2.1 foxr 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 {
1.178.2.4 albertel 2326: my $cmd = shift;
2327: my $tail = shift;
2328: my $client = shift;
1.178.2.10 foxr 2329:
1.178.2.4 albertel 2330: my $userinput = "$client:$tail";
1.178.2.10 foxr 2331:
1.178.2.4 albertel 2332: my ($udom,$what)=split(/:/,$tail);
2333: chomp($what);
2334: my @queries=split(/\&/,$what);
2335: my $qresult='';
1.178.2.9 foxr 2336: my $hashref = TieDomainHash($udom, "ids", &GDBM_READER());
2337: if ($hashref) {
1.178.2.4 albertel 2338: for (my $i=0;$i<=$#queries;$i++) {
1.178.2.9 foxr 2339: $qresult.="$hashref->{$queries[$i]}&";
1.178.2.4 albertel 2340: }
1.178.2.9 foxr 2341: if (untie(%$hashref)) {
1.178.2.4 albertel 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: }
1.178.2.10 foxr 2352:
1.178.2.4 albertel 2353: return 1;
1.178.2.1 foxr 2354: }
1.178.2.3 foxr 2355:
1.178.2.1 foxr 2356: RegisterHandler("idget", \&GetIdHandler, 0, 1, 0);
1.178.2.3 foxr 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 {
1.178.2.4 albertel 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;
1.178.2.3 foxr 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 {
1.178.2.4 albertel 2416: my $cmd = shift;
2417: my $id = shift;
2418: my $client = shift;
2419: my $userinput = "$cmd:$id";
1.178.2.10 foxr 2420:
1.178.2.4 albertel 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: }
1.178.2.3 foxr 2433:
1.178.2.4 albertel 2434: return 1;
1.178.2.3 foxr 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 {
1.178.2.4 albertel 2452: my $cmd = shift;
2453: my $id = shift;
2454: my $client = shift;
1.178.2.10 foxr 2455:
1.178.2.4 albertel 2456: my $userinput= "$cmd:$id";
1.178.2.10 foxr 2457:
1.178.2.4 albertel 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: }
1.178.2.10 foxr 2467:
1.178.2.4 albertel 2468: return 1;
1.178.2.3 foxr 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 {
1.178.2.4 albertel 2489: my $cmd = shift;
2490: my $ulsdir = shift;
2491: my $client = shift;
1.178.2.3 foxr 2492:
1.178.2.4 albertel 2493: my $userinput = "$cmd:$ulsdir";
1.178.2.3 foxr 2494:
1.178.2.4 albertel 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;
1.178.2.3 foxr 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 {
1.178.2.4 albertel 2543: my $cmd = shift;
2544: my $announcement = shift;
2545: my $client = shift;
1.178.2.3 foxr 2546:
1.178.2.4 albertel 2547: my $userinput = "$cmd:$announcement";
1.178.2.3 foxr 2548:
1.178.2.4 albertel 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: }
1.178.2.3 foxr 2559:
1.178.2.4 albertel 2560: return 1;
1.178.2.3 foxr 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 {
1.178.2.4 albertel 2578: my $client = shift;
2579: my $tail = shift;
2580: my $client = shift;
2581: my $userinput = $client;
2582:
2583: Reply($client, &version($userinput)."\n", $userinput);
1.178.2.3 foxr 2584:
2585:
1.178.2.4 albertel 2586: return 1;
1.178.2.3 foxr 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 {
1.178.2.4 albertel 2608: my $cmd = shift;
2609: my $tail = shift;
2610: my $socket = shift;
1.178.2.3 foxr 2611:
1.178.2.4 albertel 2612: my $userinput ="$cmd:$tail";
1.178.2.3 foxr 2613:
1.178.2.4 albertel 2614: Reply($client, &sethost($userinput)."\n", $userinput);
1.178.2.3 foxr 2615:
2616:
1.178.2.4 albertel 2617: return 1;
1.178.2.3 foxr 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 {
1.178.2.4 albertel 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();
1.178.2.3 foxr 2643:
1.178.2.4 albertel 2644: return 0;
1.178.2.3 foxr 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!
1.178.2.1 foxr 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 {
1.178.2.4 albertel 2662: my $Request = shift;
2663: my $KeepGoing = 1; # Assume we're not asked to stop.
1.178.2.1 foxr 2664:
1.178.2.4 albertel 2665: my $wasenc=0;
2666: my $userinput = $Request; # for compatibility with oldcode <yeach>
1.178.2.1 foxr 2667:
2668:
2669: # ------------------------------------------------------------ See if encrypted
2670:
1.178.2.4 albertel 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.
1.178.2.1 foxr 2680:
1.178.2.4 albertel 2681: my ($command, $tail) = split(/:/, $userinput, 2);
1.178.2.2 foxr 2682:
1.178.2.4 albertel 2683: Debug("Command received: $command, encoded = $wasenc");
1.178.2.2 foxr 2684:
1.178.2.1 foxr 2685:
2686: # ------------------------------------------------------------- Normal commands
2687:
1.178.2.4 albertel 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");
1.178.2.1 foxr 2698:
1.178.2.4 albertel 2699: # Validate the request:
1.178.2.1 foxr 2700:
1.178.2.4 albertel 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: }
1.161 foxr 2725:
2726:
1.178.2.1 foxr 2727: # ------------------------------------------------------------- unknown command
1.97 foxr 2728:
1.178.2.4 albertel 2729: } else {
1.178.2.1 foxr 2730: # unknown command
1.178.2.4 albertel 2731: Failure($client, "unknown_cmd\n", $userinput);
2732: }
1.97 foxr 2733:
1.178.2.1 foxr 2734: return $KeepGoing;
2735: }
1.97 foxr 2736:
1.96 foxr 2737:
2738: #
1.140 foxr 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: }
1.161 foxr 2754:
2755:
2756:
1.156 foxr 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:
1.178.2.4 albertel 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
1.161 foxr 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: #
1.178.2.4 albertel 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: }
1.156 foxr 2805: }
1.140 foxr 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:
1.163 foxr 2817: return isManager;
1.140 foxr 2818: }
2819: #
1.143 foxr 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:
1.178.2.4 albertel 2838: # Read the old file.
1.143 foxr 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: }
1.157 foxr 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:
1.178.2.4 albertel 2891: foreach my $line (split(/\n/,$contents)) {
1.157 foxr 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) {
1.178.2.4 albertel 2896: my $ip = gethostbyname($name);
2897: my $ipnew = inet_ntoa($ip);
2898: $ip = $ipnew;
1.157 foxr 2899: # Reconstruct the host line and append to adjusted:
2900:
1.178.2.4 albertel 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";
1.157 foxr 2906:
1.178.2.4 albertel 2907: } else { # Not me, pass unmodified.
2908: $adjusted .= $line."\n";
2909: }
1.157 foxr 2910: } else { # Blank or comment never re-written.
2911: $adjusted .= $line."\n"; # Pass blanks and comments as is.
2912: }
1.178.2.4 albertel 2913: }
2914: return $adjusted;
1.157 foxr 2915: }
1.143 foxr 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:
1.178.2.4 albertel 2937:
1.143 foxr 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:
1.178.2.4 albertel 2944:
1.143 foxr 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: }
1.169 foxr 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;
1.143 foxr 2979:
1.169 foxr 2980: }
1.143 foxr 2981: #
1.141 foxr 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:
1.169 foxr 3010:
3011: my $tablefile = ConfigFileFromSelector($filename);
3012: if(! (defined $tablefile)) {
1.141 foxr 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/;
1.143 foxr 3022: if(!CopyFile($tablefile, $backupfile)) {
3023: &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
3024: return "error:$!";
3025: }
1.141 foxr 3026: &logthis('<font color="green"> Pushfile: backed up '
1.178.2.4 albertel 3027: .$tablefile." to $backupfile</font>");
1.141 foxr 3028:
1.157 foxr 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:
1.141 foxr 3039: # Install the new file:
3040:
1.143 foxr 3041: if(!InstallFile($tablefile, $contents)) {
3042: &logthis('<font color="red"> Pushfile: unable to install '
1.178.2.4 albertel 3043: .$tablefile." $! </font>");
1.143 foxr 3044: return "error:$!";
1.178.2.4 albertel 3045: } else {
1.143 foxr 3046: &logthis('<font color="green"> Installed new '.$tablefile
3047: ."</font>");
1.178.2.4 albertel 3048:
1.143 foxr 3049: }
3050:
1.141 foxr 3051:
3052: # Indicate success:
3053:
3054: return "ok";
3055:
3056: }
1.145 foxr 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:
1.146 foxr 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);
1.147 foxr 3082: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
1.146 foxr 3083: if($process eq 'lonc') {
3084: $processpidfile = $processpidfile."lonc.pid";
1.147 foxr 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);
1.146 foxr 3093: } elsif ($process eq 'lond') {
1.147 foxr 3094: logthis('<font color="red"> Reinitializing self (lond) </font>');
3095: &UpdateHosts; # Lond is us!!
1.146 foxr 3096: } else {
3097: &logthis('<font color="yellow" Invalid reinit request for '.$process
3098: ."</font>");
3099: return "error:Invalid process identifier $process";
3100: }
1.145 foxr 3101: return 'ok';
3102: }
1.168 foxr 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).
1.167 foxr 3109: #
1.168 foxr 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: }
1.169 foxr 3135: } elsif ($command eq "replace") {
1.168 foxr 3136: #
3137: # key and newline:
3138: #
3139: if (($key eq "") || ($newline eq "")) {
3140: return 0;
3141: } else {
3142: return 1;
3143: }
1.169 foxr 3144: } elsif ($command eq "append") {
3145: if (($key ne "") && ($newline eq "")) {
3146: return 1;
3147: } else {
3148: return 0;
3149: }
1.168 foxr 3150: } else {
3151: return 0; # Invalid command.
3152: }
3153: return 0; # Should not get here!!!
3154: }
1.169 foxr 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!!!
1.178.2.4 albertel 3185: die "Invalid command given to ApplyEdit $command";
1.169 foxr 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;
1.168 foxr 3256:
1.169 foxr 3257: CopyFile ($filename, $filename.".old");
3258:
3259: my $contents = $editor->Get(); # Get the contents of the file.
3260:
3261: InstallFile($filename, $contents);
3262: }
1.168 foxr 3263: #
3264: #
3265: # Called to edit a configuration table file
1.167 foxr 3266: # Parameters:
3267: # request - The entire command/request sent by lonc or lonManage
3268: # Return:
3269: # The reply to send to the client.
1.168 foxr 3270: #
1.167 foxr 3271: sub EditFile {
3272: my $request = shift;
3273:
3274: # Split the command into it's pieces: edit:filetype:script
3275:
1.168 foxr 3276: my ($request, $filetype, $script) = split(/:/, $request,3); # : in script
1.167 foxr 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.
1.168 foxr 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: }
1.145 foxr 3298:
1.167 foxr 3299: # Execute the edit operation.
1.169 foxr 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);
1.167 foxr 3308:
1.169 foxr 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);
1.167 foxr 3321:
3322: return "ok\n";
3323: }
1.141 foxr 3324: #
1.96 foxr 3325: # Convert an error return code from lcpasswd to a string value.
3326: #
3327: sub lcpasswdstrerror {
3328: my $ErrorCode = shift;
1.97 foxr 3329: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
1.96 foxr 3330: return "lcpasswd Unrecognized error return value ".$ErrorCode;
3331: } else {
1.98 foxr 3332: return $passwderrors[$ErrorCode];
1.96 foxr 3333: }
3334: }
3335:
1.97 foxr 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 {
1.98 foxr 3344: return $adderrors[$ErrorCode];
1.97 foxr 3345: }
3346: }
3347:
1.23 harris41 3348: # grabs exception and records it to log before exiting
3349: sub catchexception {
1.27 albertel 3350: my ($error)=@_;
1.25 www 3351: $SIG{'QUIT'}='DEFAULT';
3352: $SIG{__DIE__}='DEFAULT';
1.165 albertel 3353: &status("Catching exception");
1.23 harris41 3354: &logthis("<font color=red>CRITICAL: "
1.178.2.4 albertel 3355: ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
3356: ."a crash with this error msg->[$error]</font>");
1.57 www 3357: &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27 albertel 3358: if ($client) { print $client "error: $error\n"; }
1.59 www 3359: $server->close();
1.27 albertel 3360: die($error);
1.23 harris41 3361: }
3362:
1.63 www 3363: sub timeout {
1.165 albertel 3364: &status("Handling Timeout");
1.63 www 3365: &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
3366: &catchexception('Timeout');
3367: }
1.22 harris41 3368: # -------------------------------- Set signal handlers to record abnormal exits
3369:
3370: $SIG{'QUIT'}=\&catchexception;
3371: $SIG{__DIE__}=\&catchexception;
3372:
1.81 matthew 3373: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
1.95 harris41 3374: &status("Read loncapa.conf and loncapa_apache.conf");
3375: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.141 foxr 3376: %perlvar=%{$perlvarref};
1.80 harris41 3377: undef $perlvarref;
1.19 www 3378:
1.35 harris41 3379: # ----------------------------- Make sure this process is running from user=www
3380: my $wwwid=getpwnam('www');
3381: if ($wwwid!=$<) {
1.178.2.4 albertel 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.' |\
1.35 harris41 3385: mailto $emailto -s '$subj' > /dev/null");
1.178.2.4 albertel 3386: exit 1;
1.35 harris41 3387: }
3388:
1.19 www 3389: # --------------------------------------------- Check if other instance running
3390:
3391: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
3392:
3393: if (-e $pidfile) {
1.178.2.4 albertel 3394: my $lfh=IO::File->new("$pidfile");
3395: my $pide=<$lfh>;
3396: chomp($pide);
3397: if (kill 0 => $pide) { die "already running"; }
1.19 www 3398: }
1.1 albertel 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 )
1.178.2.4 albertel 3410: or die "making socket: $@\n";
1.1 albertel 3411:
3412: # --------------------------------------------------------- Do global variables
3413:
3414: # global variables
3415:
1.134 albertel 3416: my %children = (); # keys are current child process IDs
1.178.2.1 foxr 3417: my $children = 0; # current number of children
1.1 albertel 3418:
3419: sub REAPER { # takes care of dead children
3420: $SIG{CHLD} = \&REAPER;
1.165 albertel 3421: &status("Handling child death");
1.178.2.1 foxr 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");
1.176 albertel 3429: }
1.165 albertel 3430: &status("Finished Handling child death");
1.1 albertel 3431: }
3432:
3433: sub HUNTSMAN { # signal handler for SIGINT
1.165 albertel 3434: &status("Killing children (INT)");
1.1 albertel 3435: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
3436: kill 'INT' => keys %children;
1.59 www 3437: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1 albertel 3438: my $execdir=$perlvar{'lonDaemons'};
3439: unlink("$execdir/logs/lond.pid");
1.9 www 3440: &logthis("<font color=red>CRITICAL: Shutting down</font>");
1.165 albertel 3441: &status("Done killing children");
1.1 albertel 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
1.165 albertel 3447: &status("Killing children for restart (HUP)");
1.1 albertel 3448: kill 'INT' => keys %children;
1.59 www 3449: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.9 www 3450: &logthis("<font color=red>CRITICAL: Restarting</font>");
1.134 albertel 3451: my $execdir=$perlvar{'lonDaemons'};
1.30 harris41 3452: unlink("$execdir/logs/lond.pid");
1.165 albertel 3453: &status("Restarting self (HUP)");
1.1 albertel 3454: exec("$execdir/lond"); # here we go again
3455: }
3456:
1.144 foxr 3457: #
1.148 foxr 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>) {
1.178.2.1 foxr 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; }
1.148 foxr 3490: }
3491: close(CONFIG);
3492: }
3493: #
3494: # Reload the Apache daemon's state.
1.150 foxr 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.
1.148 foxr 3497: #
3498: sub ReloadApache {
1.150 foxr 3499: my $execdir = $perlvar{'lonDaemons'};
3500: my $script = $execdir."/apachereload";
3501: system($script);
1.148 foxr 3502: }
3503:
3504: #
1.144 foxr 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 {
1.165 albertel 3515: &status("Reload hosts.tab");
1.147 foxr 3516: logthis('<font color="blue"> Updating connections </font>');
1.148 foxr 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}) {
1.149 foxr 3531: logthis('<font color="blue"> UpdateHosts killing child '
3532: ." $child for ip $childip </font>");
1.148 foxr 3533: kill('INT', $child);
1.149 foxr 3534: } else {
3535: logthis('<font color="green"> keeping child for ip '
3536: ." $childip (pid=$child) </font>");
1.148 foxr 3537: }
3538: }
3539: ReloadApache;
1.165 albertel 3540: &status("Finished reloading hosts.tab");
1.144 foxr 3541: }
3542:
1.148 foxr 3543:
1.57 www 3544: sub checkchildren {
1.165 albertel 3545: &status("Checking on the children (sending signals)");
1.57 www 3546: &initnewstatus();
3547: &logstatus();
3548: &logthis('Going to check on the children');
1.134 albertel 3549: my $docdir=$perlvar{'lonDocRoot'};
1.61 harris41 3550: foreach (sort keys %children) {
1.57 www 3551: sleep 1;
3552: unless (kill 'USR1' => $_) {
3553: &logthis ('Child '.$_.' is dead');
3554: &logstatus($$.' is dead');
3555: }
1.61 harris41 3556: }
1.63 www 3557: sleep 5;
1.113 albertel 3558: $SIG{ALRM} = sub { die "timeout" };
3559: $SIG{__DIE__} = 'DEFAULT';
1.165 albertel 3560: &status("Checking on the children (waiting for reports)");
1.63 www 3561: foreach (sort keys %children) {
3562: unless (-e "$docdir/lon-status/londchld/$_.txt") {
1.178.2.4 albertel 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: }
1.63 www 3574: }
3575: }
1.113 albertel 3576: $SIG{ALRM} = 'DEFAULT';
1.155 albertel 3577: $SIG{__DIE__} = \&catchexception;
1.165 albertel 3578: &status("Finished checking children");
1.57 www 3579: }
3580:
1.1 albertel 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);
1.58 www 3589: $lastlog=$local.': '.$message;
1.1 albertel 3590: print $fh "$local ($$): $message\n";
3591: }
3592:
1.77 foxr 3593: # ------------------------- Conditional log if $DEBUG true.
3594: sub Debug {
3595: my $message = shift;
3596: if($DEBUG) {
3597: &logthis($message);
3598: }
3599: }
1.161 foxr 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: #
1.178.2.1 foxr 3609: # Note: This increments Transactions
3610: #
1.161 foxr 3611: sub Reply {
1.178.2.1 foxr 3612: alarm(120);
1.161 foxr 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:
1.178.2.1 foxr 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 {
1.178.2.4 albertel 3641: my $fd = shift;
3642: my $reply = shift;
3643: my $request = shift;
1.178.2.1 foxr 3644:
1.178.2.4 albertel 3645: $Failures++;
3646: Reply($fd, $reply, $request); # That's simple eh?
1.161 foxr 3647: }
1.57 www 3648: # ------------------------------------------------------------------ Log status
3649:
3650: sub logstatus {
1.178.2.4 albertel 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");
1.178.2.1 foxr 3666:
1.57 www 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";
1.64 www 3675: opendir(DIR,"$docdir/lon-status/londchld");
1.134 albertel 3676: while (my $filename=readdir(DIR)) {
1.64 www 3677: unlink("$docdir/lon-status/londchld/$filename");
3678: }
3679: closedir(DIR);
1.57 www 3680: }
3681:
3682: # -------------------------------------------------------------- Status setting
3683:
3684: sub status {
3685: my $what=shift;
3686: my $now=time;
3687: my $local=localtime($now);
1.178.2.1 foxr 3688: my $status = "lond: $what $local ";
3689: if($Transactions) {
1.178.2.4 albertel 3690: $status .= " Transactions: $Transactions Failed; $Failures";
1.178.2.1 foxr 3691: }
3692: $0=$status;
1.57 www 3693: }
1.11 www 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:
1.1 albertel 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 {
1.178.2.4 albertel 3724: &logthis("<font color=red>CRITICAL: "
3725: ."lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 3726: }
3727: } else {
1.178.2.4 albertel 3728: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
1.1 albertel 3729: }
3730: }
3731:
3732: # -------------------------------------------------- Non-critical communication
1.11 www 3733:
1.1 albertel 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)
1.178.2.4 albertel 3740: or return "con_lost";
1.1 albertel 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 {
1.178.2.4 albertel 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;
1.1 albertel 3765: }
3766:
1.13 www 3767: # -------------------------------------------------------------- Talk to lonsql
3768:
1.12 harris41 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)
1.178.2.4 albertel 3783: or return "con_lost";
1.12 harris41 3784: print $sclient "$cmd\n";
3785: my $answer=<$sclient>;
3786: chomp($answer);
3787: if (!$answer) { $answer="con_lost"; }
3788: return $answer;
3789: }
3790:
1.1 albertel 3791: # -------------------------------------------- Return path to profile directory
1.11 www 3792:
1.1 albertel 3793: sub propath {
3794: my ($udom,$uname)=@_;
1.178.2.11 foxr 3795: Debug("Propath:$udom:$uname");
1.1 albertel 3796: $udom=~s/\W//g;
3797: $uname=~s/\W//g;
1.178.2.11 foxr 3798: Debug("Propath2:$udom:$uname");
1.16 www 3799: my $subdir=$uname.'__';
1.1 albertel 3800: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
3801: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
1.178.2.11 foxr 3802: Debug("Propath returning $proname");
1.1 albertel 3803: return $proname;
3804: }
3805:
3806: # --------------------------------------- Is this the home server of an author?
1.11 www 3807:
1.1 albertel 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:
1.134 albertel 3823: my $fpid=fork;
1.1 albertel 3824: exit if $fpid;
1.29 harris41 3825: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 3826:
1.29 harris41 3827: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 3828:
3829: # ------------------------------------------------------- Write our PID on disk
3830:
1.134 albertel 3831: my $execdir=$perlvar{'lonDaemons'};
1.1 albertel 3832: open (PIDSAVE,">$execdir/logs/lond.pid");
3833: print PIDSAVE "$$\n";
3834: close(PIDSAVE);
1.9 www 3835: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
1.57 www 3836: &status('Starting');
1.1 albertel 3837:
1.106 foxr 3838:
1.1 albertel 3839:
3840: # ----------------------------------------------------- Install signal handlers
3841:
1.57 www 3842:
1.1 albertel 3843: $SIG{CHLD} = \&REAPER;
3844: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
3845: $SIG{HUP} = \&HUPSMAN;
1.57 www 3846: $SIG{USR1} = \&checkchildren;
1.144 foxr 3847: $SIG{USR2} = \&UpdateHosts;
1.106 foxr 3848:
1.148 foxr 3849: # Read the host hashes:
3850:
3851: ReadHostTable;
1.106 foxr 3852:
1.178.2.1 foxr 3853:
1.106 foxr 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:
1.1 albertel 3859: while (1) {
1.165 albertel 3860: &status('Starting accept');
1.106 foxr 3861: $client = $server->accept() or next;
1.165 albertel 3862: &status('Accepted '.$client.' off to spawn');
1.106 foxr 3863: make_new_child($client);
1.165 albertel 3864: &status('Finished spawning');
1.1 albertel 3865: }
3866:
3867: sub make_new_child {
3868: my $pid;
3869: my $sigset;
1.106 foxr 3870:
3871: $client = shift;
1.165 albertel 3872: &status('Starting new child '.$client);
1.161 foxr 3873: &logthis('<font color="green"> Attempting to start child ('.$client.
3874: ")</font>");
1.1 albertel 3875: # block signal for fork
3876: $sigset = POSIX::SigSet->new(SIGINT);
3877: sigprocmask(SIG_BLOCK, $sigset)
1.29 harris41 3878: or die "Can't block SIGINT for fork: $!\n";
1.178.2.4 albertel 3879:
1.29 harris41 3880: die "fork: $!" unless defined ($pid = fork);
1.148 foxr 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);
1.1 albertel 3892:
3893: if ($pid) {
3894: # Parent records the child's birth and returns.
3895: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 3896: or die "Can't unblock SIGINT for fork: $!\n";
1.148 foxr 3897: $children{$pid} = $clientip;
1.178.2.1 foxr 3898: $children++;
1.57 www 3899: &status('Started child '.$pid);
1.1 albertel 3900: return;
3901: } else {
3902: # Child can *not* return from this subroutine.
3903: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
1.126 albertel 3904: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
3905: #don't get intercepted
1.57 www 3906: $SIG{USR1}= \&logstatus;
1.63 www 3907: $SIG{ALRM}= \&timeout;
1.57 www 3908: $lastlog='Forked ';
3909: $status='Forked';
3910:
1.1 albertel 3911: # unblock signals
3912: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 3913: or die "Can't unblock SIGINT for fork: $!\n";
1.13 www 3914:
1.178.2.1 foxr 3915:
3916:
1.91 albertel 3917: &Authen::Krb5::init_context();
3918: &Authen::Krb5::init_ets();
1.178.2.4 albertel 3919:
1.161 foxr 3920: &status('Accepted connection');
1.1 albertel 3921: # =============================================================================
3922: # do something with the connection
3923: # -----------------------------------------------------------------------------
1.148 foxr 3924: # see if we know client and check for spoof IP by challenge
3925:
1.161 foxr 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.
1.178.2.4 albertel 3946: " ($clientname) connection type = $ConnectionType </font>" );
1.161 foxr 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";
1.178.2.4 albertel 3954: &status("Waiting for challenge reply from $clientip ($clientname)");
1.161 foxr 3955: $remotereq=<$client>;
3956: $remotereq=~s/\W//g;
3957: if ($challenge eq $remotereq) {
3958: $clientok=1;
3959: print $client "ok\n";
3960: } else {
1.178.2.4 albertel 3961: &logthis("<font color=blue>WARNING: $clientip did not reply challenge</font>");
1.161 foxr 3962: &status('No challenge reply '.$clientip);
3963: }
1.2 www 3964: } else {
1.178.2.4 albertel 3965: &logthis("<font color=blue>WARNING: "
1.161 foxr 3966: ."$clientip failed to initialize: >$remotereq< </font>");
3967: &status('No init '.$clientip);
3968: }
3969: } else {
1.178.2.4 albertel 3970: &logthis("<font color=blue>WARNING: Unknown client $clientip</font>");
1.161 foxr 3971: &status('Hung up on '.$clientip);
3972: }
3973: if ($clientok) {
1.1 albertel 3974: # ---------------- New known client connecting, could mean machine online again
1.161 foxr 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;
1.115 albertel 3981: }
1.161 foxr 3982: &reconlonc("$perlvar{'lonSockDir'}/$id");
3983: }
3984: &logthis("<font color=green>Established connection: $clientname</font>");
3985: &status('Will listen to '.$clientname);
3986:
1.178.2.1 foxr 3987: ResetStatistics();
1.161 foxr 3988:
1.178.2.1 foxr 3989: # ------------------------------------------------------------ Process requests
3990: my $KeepGoing = 1;
3991: while ((my $userinput=GetRequest) && $KeepGoing) {
3992: $KeepGoing = ProcessRequest($userinput);
1.177 foxr 3993: # -------------------------------------------------------------------- complete
1.178.2.1 foxr 3994:
1.161 foxr 3995: &status('Listening to '.$clientname);
3996: }
1.59 www 3997: # --------------------------------------------- client unknown or fishy, refuse
1.161 foxr 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:
1.1 albertel 4006: # =============================================================================
1.161 foxr 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;
1.106 foxr 4016:
1.78 foxr 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: #
1.178.2.4 albertel 4031: sub ManagePermissions {
1.78 foxr 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
1.178.2.1 foxr 4038: &logthis("ruequest is $request");
1.78 foxr 4039: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
4040: my $execdir = $perlvar{'lonDaemons'};
4041: my $userhome= "/home/$user" ;
1.134 albertel 4042: &logthis("system $execdir/lchtmldir $userhome $user $authtype");
1.78 foxr 4043: system("$execdir/lchtmldir $userhome $user $authtype");
4044: }
4045: }
1.178.2.8 foxr 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);
1.178.2.11 foxr 4060: $path .= "/passwd";
1.178.2.8 foxr 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:
1.178.2.11 foxr 4079: Debug ("PasswordFilename called: dom = $domain user = $user");
1.178.2.8 foxr 4080:
1.178.2.11 foxr 4081: my $path = PasswordPath($domain, $user);
4082: Debug("PasswordFilename got path: $path");
1.178.2.8 foxr 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: }
1.78 foxr 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: #
1.178.2.4 albertel 4124: sub GetAuthType {
1.78 foxr 4125: my $domain = shift;
4126: my $user = shift;
4127:
1.79 foxr 4128: Debug("GetAuthType( $domain, $user ) \n");
1.178.2.8 foxr 4129: my $passwdfile = PasswordFilename($domain, $user);
4130: if( defined $passwdfile ) {
1.78 foxr 4131: my $pf = IO::File->new($passwdfile);
4132: my $realpassword = <$pf>;
4133: chomp($realpassword);
1.79 foxr 4134: Debug("Password info = $realpassword\n");
1.178.2.8 foxr 4135: return $realpassword;
1.178.2.4 albertel 4136: } else {
1.79 foxr 4137: Debug("Returning nouser");
1.78 foxr 4138: return "nouser";
4139: }
1.1 albertel 4140: }
4141:
1.178.2.13! foxr 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: #
1.84 albertel 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;
1.134 albertel 4277: my $sh;
1.84 albertel 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;
1.86 www 4289: }
1.178.2.13! foxr 4290: #
! 4291: # Get chat messages.
! 4292: #
1.86 www 4293: sub getchat {
1.122 www 4294: my ($cdom,$cname,$udom,$uname)=@_;
1.87 www 4295: my %hash;
4296: my $proname=&propath($cdom,$cname);
4297: my @entries=();
1.88 albertel 4298: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
4299: &GDBM_READER(),0640)) {
4300: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
4301: untie %hash;
1.123 www 4302: }
1.124 www 4303: my @participants=();
1.134 albertel 4304: my $cutoff=time-60;
1.123 www 4305: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
1.124 www 4306: &GDBM_WRCREAT(),0640)) {
4307: $hash{$uname.':'.$udom}=time;
1.123 www 4308: foreach (sort keys %hash) {
4309: if ($hash{$_}>$cutoff) {
1.124 www 4310: $participants[$#participants+1]='active_participant:'.$_;
1.123 www 4311: }
4312: }
4313: untie %hash;
1.86 www 4314: }
1.124 www 4315: return (@participants,@entries);
1.86 www 4316: }
1.178.2.13! foxr 4317: #
! 4318: # Add a chat message
! 4319: #
1.86 www 4320: sub chatadd {
1.88 albertel 4321: my ($cdom,$cname,$newchat)=@_;
4322: my %hash;
4323: my $proname=&propath($cdom,$cname);
4324: my @entries=();
1.142 www 4325: my $time=time;
1.88 albertel 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) {
1.89 www 4343: delete $hash{$_};
1.88 albertel 4344: }
4345: }
4346: untie %hash;
1.142 www 4347: }
4348: {
4349: my $hfh;
4350: if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
4351: print $hfh "$time:".&unescape($newchat)."\n";
4352: }
1.86 www 4353: }
1.84 albertel 4354: }
4355:
4356: sub unsub {
4357: my ($fname,$clientip)=@_;
4358: my $result;
1.161 foxr 4359: if (unlink("$fname.$clientname")) {
1.84 albertel 4360: $result="ok\n";
4361: } else {
4362: $result="not_subscribed\n";
4363: }
4364: if (-e "$fname.subscription") {
1.161 foxr 4365: my $found=&addline($fname,$clientname,$clientip,'');
1.84 albertel 4366: if ($found) { $result="ok\n"; }
4367: } else {
4368: if ($result != "ok\n") { $result="not_subscribed\n"; }
4369: }
4370: return $result;
4371: }
4372:
1.101 www 4373: sub currentversion {
4374: my $fname=shift;
4375: my $version=-1;
4376: my $ulsdir='';
4377: if ($fname=~/^(.+)\/[^\/]+$/) {
1.178.2.4 albertel 4378: $ulsdir=$1;
1.101 www 4379: }
1.114 albertel 4380: my ($fnamere1,$fnamere2);
4381: # remove version if already specified
1.101 www 4382: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
1.114 albertel 4383: # get the bits that go before and after the version number
4384: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
4385: $fnamere1=$1;
4386: $fnamere2='.'.$2;
4387: }
1.101 www 4388: if (-e $fname) { $version=1; }
4389: if (-e $ulsdir) {
1.134 albertel 4390: if(-d $ulsdir) {
4391: if (opendir(LSDIR,$ulsdir)) {
4392: my $ulsfn;
4393: while ($ulsfn=readdir(LSDIR)) {
1.101 www 4394: # see if this is a regular file (ignore links produced earlier)
1.134 albertel 4395: my $thisfile=$ulsdir.'/'.$ulsfn;
4396: unless (-l $thisfile) {
1.160 www 4397: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) {
1.134 albertel 4398: if ($1>$version) { $version=$1; }
4399: }
4400: }
4401: }
4402: closedir(LSDIR);
4403: $version++;
4404: }
4405: }
4406: }
4407: return $version;
1.101 www 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:
1.84 albertel 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') {
1.101 www 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);
1.102 www 4434: unless ($extension=~/\.meta$/) {
1.178.2.4 albertel 4435: symlink($root.'.'.$extension.'.meta',
4436: $root.'.'.$currentversion.'.'.$extension.'.meta');
1.102 www 4437: }
1.101 www 4438: }
4439: }
4440: }
1.84 albertel 4441: if (-e $fname) {
4442: if (-d $fname) {
4443: $result="directory\n";
4444: } else {
1.161 foxr 4445: if (-e "$fname.$clientname") {&unsub($fname,$clientip);}
1.134 albertel 4446: my $now=time;
1.161 foxr 4447: my $found=&addline($fname,$clientname,$clientip,
4448: "$clientname:$clientip:$now\n");
1.84 albertel 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: }
1.91 albertel 4466:
4467: sub make_passwd_file {
1.98 foxr 4468: my ($uname, $umode,$npass,$passfilename)=@_;
1.91 albertel 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);
1.98 foxr 4494: &Debug("user = ".$uname.", Password =". $npass);
1.132 matthew 4495: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
1.91 albertel 4496: print $se "$uname\n";
4497: print $se "$npass\n";
4498: print $se "$npass\n";
1.97 foxr 4499: }
4500: my $useraddok = $?;
4501: if($useraddok > 0) {
4502: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
1.91 albertel 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;
1.121 albertel 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";
1.127 albertel 4538: }
1.178.2.1 foxr 4539: ############## >>>>>>>>>>>>>>>>>>>>>>>>>> FUTUREWORK <<<<<<<<<<<<<<<<<<<<<<<<<<<<
1.128 albertel 4540: #There is a copy of this in lonnet.pm
1.178.2.1 foxr 4541: # Can we hoist these lil' things out into common places?
4542: #
1.127 albertel 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;}
1.138 albertel 4551: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
1.159 albertel 4552: if ($curtime-$mtime < 1800) { $numusers++; }
1.127 albertel 4553: }
4554: closedir(LONIDS);
4555: }
4556: my $userloadpercent=0;
4557: my $maxuserload=$perlvar{'lonUserLoadLim'};
4558: if ($maxuserload) {
1.129 albertel 4559: $userloadpercent=100*$numusers/$maxuserload;
1.127 albertel 4560: }
1.130 albertel 4561: $userloadpercent=sprintf("%.2f",$userloadpercent);
1.127 albertel 4562: return $userloadpercent;
1.91 albertel 4563: }
4564:
1.61 harris41 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:
1.74 harris41 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.)
1.61 harris41 4579:
4580: =head1 DESCRIPTION
4581:
1.74 harris41 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:
1.61 harris41 4590: Preforker - server who forks first. Runs as a daemon. HUPs.
4591: Uses IDEA encryption
4592:
1.74 harris41 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.
1.144 foxr 4671:
4672: =item *
4673:
4674: SIGUSR2
4675:
4676: Parent Signal assignment:
4677: $SIG{USR2} = \&UpdateHosts
4678:
4679: Child signal assignment:
4680: NONE
4681:
1.74 harris41 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
1.61 harris41 4749:
1.74 harris41 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:
1.135 foxr 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:
1.74 harris41 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".
1.135 foxr 4865:
1.74 harris41 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
1.61 harris41 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
1.91 albertel 4886: Authen::Krb5
1.61 harris41 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>
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom