Annotation of loncom/lond, revision 1.209
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 www 4: #
1.209 ! albertel 5: # $Id: lond,v 1.208 2004/07/23 13:36:29 albertel Exp $
1.60 www 6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
1.167 foxr 13: # the Free Software Foundation; either version 2 of the License, or
1.60 www 14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
1.178 foxr 23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
1.60 www 24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
1.161 foxr 27:
28:
1.60 www 29: # http://www.lon-capa.org/
30: #
1.54 harris41 31:
1.134 albertel 32: use strict;
1.80 harris41 33: use lib '/home/httpd/lib/perl/';
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.193 raeburn 48: use localenroll;
1.143 foxr 49: use File::Copy;
1.169 foxr 50: use LONCAPA::ConfigFileEdit;
1.200 matthew 51: use LONCAPA::lonlocal;
52: use LONCAPA::lonssl;
1.1 albertel 53:
1.204 albertel 54: my $DEBUG = 0; # Non zero to enable debug log entries.
1.77 foxr 55:
1.57 www 56: my $status='';
57: my $lastlog='';
58:
1.209 ! albertel 59: my $VERSION='$Revision: 1.208 $'; #' stupid emacs
1.121 albertel 60: my $remoteVERSION;
1.115 albertel 61: my $currenthostid;
62: my $currentdomainid;
1.134 albertel 63:
64: my $client;
1.200 matthew 65: my $clientip; # IP address of client.
66: my $clientdns; # DNS name of client.
67: my $clientname; # LonCAPA name of client.
1.140 foxr 68:
1.134 albertel 69: my $server;
1.200 matthew 70: my $thisserver; # DNS of us.
71:
72: my $keymode;
1.198 foxr 73:
1.207 foxr 74: my $cipher; # Cipher key negotiated with client
75: my $tmpsnum = 0; # Id of tmpputs.
76:
1.178 foxr 77: #
78: # Connection type is:
79: # client - All client actions are allowed
80: # manager - only management functions allowed.
81: # both - Both management and client actions are allowed
82: #
1.161 foxr 83:
1.178 foxr 84: my $ConnectionType;
1.161 foxr 85:
1.200 matthew 86: my %hostid; # ID's for hosts in cluster by ip.
87: my %hostdom; # LonCAPA domain for hosts in cluster.
88: my %hostip; # IPs for hosts in cluster.
89: my %hostdns; # ID's of hosts looked up by DNS name.
1.161 foxr 90:
1.178 foxr 91: my %managers; # Ip -> manager names
1.161 foxr 92:
1.178 foxr 93: my %perlvar; # Will have the apache conf defined perl vars.
1.134 albertel 94:
1.178 foxr 95: #
1.207 foxr 96: # The hash below is used for command dispatching, and is therefore keyed on the request keyword.
97: # Each element of the hash contains a reference to an array that contains:
98: # A reference to a sub that executes the request corresponding to the keyword.
99: # A flag that is true if the request must be encoded to be acceptable.
100: # A mask with bits as follows:
101: # CLIENT_OK - Set when the function is allowed by ordinary clients
102: # MANAGER_OK - Set when the function is allowed to manager clients.
103: #
104: my $CLIENT_OK = 1;
105: my $MANAGER_OK = 2;
106: my %Dispatcher;
107:
108:
109: #
1.178 foxr 110: # The array below are password error strings."
111: #
112: my $lastpwderror = 13; # Largest error number from lcpasswd.
113: my @passwderrors = ("ok",
114: "lcpasswd must be run as user 'www'",
115: "lcpasswd got incorrect number of arguments",
116: "lcpasswd did not get the right nubmer of input text lines",
117: "lcpasswd too many simultaneous pwd changes in progress",
118: "lcpasswd User does not exist.",
119: "lcpasswd Incorrect current passwd",
120: "lcpasswd Unable to su to root.",
121: "lcpasswd Cannot set new passwd.",
122: "lcpasswd Username has invalid characters",
123: "lcpasswd Invalid characters in password",
124: "11", "12",
125: "lcpasswd Password mismatch");
1.97 foxr 126:
127:
1.178 foxr 128: # The array below are lcuseradd error strings.:
1.97 foxr 129:
1.178 foxr 130: my $lastadderror = 13;
131: my @adderrors = ("ok",
132: "User ID mismatch, lcuseradd must run as user www",
133: "lcuseradd Incorrect number of command line parameters must be 3",
134: "lcuseradd Incorrect number of stdinput lines, must be 3",
135: "lcuseradd Too many other simultaneous pwd changes in progress",
136: "lcuseradd User does not exist",
137: "lcuseradd Unable to make www member of users's group",
138: "lcuseradd Unable to su to root",
139: "lcuseradd Unable to set password",
140: "lcuseradd Usrname has invalid characters",
141: "lcuseradd Password has an invalid character",
142: "lcuseradd User already exists",
143: "lcuseradd Could not add user.",
144: "lcuseradd Password mismatch");
1.97 foxr 145:
1.96 foxr 146:
1.207 foxr 147:
148: #
149: # Statistics that are maintained and dislayed in the status line.
150: #
151: my $Transactions; # Number of attempted transactions.
152: my $Failures; # Number of transcations failed.
153:
154: # ResetStatistics:
155: # Resets the statistics counters:
156: #
157: sub ResetStatistics {
158: $Transactions = 0;
159: $Failures = 0;
160: }
161:
162:
163:
1.200 matthew 164: #------------------------------------------------------------------------
165: #
166: # LocalConnection
167: # Completes the formation of a locally authenticated connection.
168: # This function will ensure that the 'remote' client is really the
169: # local host. If not, the connection is closed, and the function fails.
170: # If so, initcmd is parsed for the name of a file containing the
171: # IDEA session key. The fie is opened, read, deleted and the session
172: # key returned to the caller.
173: #
174: # Parameters:
175: # $Socket - Socket open on client.
176: # $initcmd - The full text of the init command.
177: #
178: # Implicit inputs:
179: # $clientdns - The DNS name of the remote client.
180: # $thisserver - Our DNS name.
181: #
182: # Returns:
183: # IDEA session key on success.
184: # undef on failure.
185: #
186: sub LocalConnection {
187: my ($Socket, $initcmd) = @_;
188: Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");
189: if($clientdns ne $thisserver) {
190: &logthis('<font color="red"> LocalConnection rejecting non local: '
191: ."$clientdns ne $thisserver </font>");
192: close $Socket;
193: return undef;
194: }
195: else {
196: chomp($initcmd); # Get rid of \n in filename.
197: my ($init, $type, $name) = split(/:/, $initcmd);
198: Debug(" Init command: $init $type $name ");
199:
200: # Require that $init = init, and $type = local: Otherwise
201: # the caller is insane:
202:
203: if(($init ne "init") && ($type ne "local")) {
204: &logthis('<font color = "red"> LocalConnection: caller is insane! '
205: ."init = $init, and type = $type </font>");
206: close($Socket);;
207: return undef;
208:
209: }
210: # Now get the key filename:
211:
212: my $IDEAKey = lonlocal::ReadKeyFile($name);
213: return $IDEAKey;
214: }
215: }
216: #------------------------------------------------------------------------------
217: #
218: # SSLConnection
219: # Completes the formation of an ssh authenticated connection. The
220: # socket is promoted to an ssl socket. If this promotion and the associated
221: # certificate exchange are successful, the IDEA key is generated and sent
222: # to the remote peer via the SSL tunnel. The IDEA key is also returned to
223: # the caller after the SSL tunnel is torn down.
224: #
225: # Parameters:
226: # Name Type Purpose
227: # $Socket IO::Socket::INET Plaintext socket.
228: #
229: # Returns:
230: # IDEA key on success.
231: # undef on failure.
232: #
233: sub SSLConnection {
234: my $Socket = shift;
235:
236: Debug("SSLConnection: ");
237: my $KeyFile = lonssl::KeyFile();
238: if(!$KeyFile) {
239: my $err = lonssl::LastError();
240: &logthis("<font color=\"red\"> CRITICAL"
241: ."Can't get key file $err </font>");
242: return undef;
243: }
244: my ($CACertificate,
245: $Certificate) = lonssl::CertificateFile();
246:
247:
248: # If any of the key, certificate or certificate authority
249: # certificate filenames are not defined, this can't work.
250:
251: if((!$Certificate) || (!$CACertificate)) {
252: my $err = lonssl::LastError();
253: &logthis("<font color=\"red\"> CRITICAL"
254: ."Can't get certificates: $err </font>");
255:
256: return undef;
257: }
258: Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate");
259:
260: # Indicate to our peer that we can procede with
261: # a transition to ssl authentication:
262:
263: print $Socket "ok:ssl\n";
264:
265: Debug("Approving promotion -> ssl");
266: # And do so:
267:
268: my $SSLSocket = lonssl::PromoteServerSocket($Socket,
269: $CACertificate,
270: $Certificate,
271: $KeyFile);
272: if(! ($SSLSocket) ) { # SSL socket promotion failed.
273: my $err = lonssl::LastError();
274: &logthis("<font color=\"red\"> CRITICAL "
275: ."SSL Socket promotion failed: $err </font>");
276: return undef;
277: }
278: Debug("SSL Promotion successful");
279:
280: #
281: # The only thing we'll use the socket for is to send the IDEA key
282: # to the peer:
283:
284: my $Key = lonlocal::CreateCipherKey();
285: print $SSLSocket "$Key\n";
286:
287: lonssl::Close($SSLSocket);
288:
289: Debug("Key exchange complete: $Key");
290:
291: return $Key;
292: }
293: #
294: # InsecureConnection:
295: # If insecure connections are allowd,
296: # exchange a challenge with the client to 'validate' the
297: # client (not really, but that's the protocol):
298: # We produce a challenge string that's sent to the client.
299: # The client must then echo the challenge verbatim to us.
300: #
301: # Parameter:
302: # Socket - Socket open on the client.
303: # Returns:
304: # 1 - success.
305: # 0 - failure (e.g.mismatch or insecure not allowed).
306: #
307: sub InsecureConnection {
308: my $Socket = shift;
309:
310: # Don't even start if insecure connections are not allowed.
311:
312: if(! $perlvar{londAllowInsecure}) { # Insecure connections not allowed.
313: return 0;
314: }
315:
316: # Fabricate a challenge string and send it..
317:
318: my $challenge = "$$".time; # pid + time.
319: print $Socket "$challenge\n";
320: &status("Waiting for challenge reply");
321:
322: my $answer = <$Socket>;
323: $answer =~s/\W//g;
324: if($challenge eq $answer) {
325: return 1;
326: }
327: else {
328: logthis("<font color='blue'>WARNING client did not respond to challenge</font>");
329: &status("No challenge reqply");
330: return 0;
331: }
332:
333:
334: }
335:
1.96 foxr 336: #
1.140 foxr 337: # GetCertificate: Given a transaction that requires a certificate,
338: # this function will extract the certificate from the transaction
339: # request. Note that at this point, the only concept of a certificate
340: # is the hostname to which we are connected.
341: #
342: # Parameter:
343: # request - The request sent by our client (this parameterization may
344: # need to change when we really use a certificate granting
345: # authority.
346: #
347: sub GetCertificate {
348: my $request = shift;
349:
350: return $clientip;
351: }
1.161 foxr 352:
1.178 foxr 353: #
354: # Return true if client is a manager.
355: #
356: sub isManager {
357: return (($ConnectionType eq "manager") || ($ConnectionType eq "both"));
358: }
359: #
360: # Return tru if client can do client functions
361: #
362: sub isClient {
363: return (($ConnectionType eq "client") || ($ConnectionType eq "both"));
364: }
1.161 foxr 365:
366:
1.156 foxr 367: #
368: # ReadManagerTable: Reads in the current manager table. For now this is
369: # done on each manager authentication because:
370: # - These authentications are not frequent
371: # - This allows dynamic changes to the manager table
372: # without the need to signal to the lond.
373: #
374:
375: sub ReadManagerTable {
376:
377: # Clean out the old table first..
378:
1.166 foxr 379: foreach my $key (keys %managers) {
380: delete $managers{$key};
381: }
382:
383: my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
384: if (!open (MANAGERS, $tablename)) {
385: logthis('<font color="red">No manager table. Nobody can manage!!</font>');
386: return;
387: }
388: while(my $host = <MANAGERS>) {
389: chomp($host);
390: if ($host =~ "^#") { # Comment line.
391: next;
392: }
393: if (!defined $hostip{$host}) { # This is a non cluster member
1.161 foxr 394: # The entry is of the form:
395: # cluname:hostname
396: # cluname - A 'cluster hostname' is needed in order to negotiate
397: # the host key.
398: # hostname- The dns name of the host.
399: #
1.166 foxr 400: my($cluname, $dnsname) = split(/:/, $host);
401:
402: my $ip = gethostbyname($dnsname);
403: if(defined($ip)) { # bad names don't deserve entry.
404: my $hostip = inet_ntoa($ip);
405: $managers{$hostip} = $cluname;
406: logthis('<font color="green"> registering manager '.
407: "$dnsname as $cluname with $hostip </font>\n");
408: }
409: } else {
410: logthis('<font color="green"> existing host'." $host</font>\n");
411: $managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber
412: }
413: }
1.156 foxr 414: }
1.140 foxr 415:
416: #
417: # ValidManager: Determines if a given certificate represents a valid manager.
418: # in this primitive implementation, the 'certificate' is
419: # just the connecting loncapa client name. This is checked
420: # against a valid client list in the configuration.
421: #
422: #
423: sub ValidManager {
424: my $certificate = shift;
425:
1.163 foxr 426: return isManager;
1.140 foxr 427: }
428: #
1.143 foxr 429: # CopyFile: Called as part of the process of installing a
430: # new configuration file. This function copies an existing
431: # file to a backup file.
432: # Parameters:
433: # oldfile - Name of the file to backup.
434: # newfile - Name of the backup file.
435: # Return:
436: # 0 - Failure (errno has failure reason).
437: # 1 - Success.
438: #
439: sub CopyFile {
1.192 foxr 440:
441: my ($oldfile, $newfile) = @_;
1.143 foxr 442:
443: # The file must exist:
444:
445: if(-e $oldfile) {
446:
447: # Read the old file.
448:
449: my $oldfh = IO::File->new("< $oldfile");
450: if(!$oldfh) {
451: return 0;
452: }
453: my @contents = <$oldfh>; # Suck in the entire file.
454:
455: # write the backup file:
456:
457: my $newfh = IO::File->new("> $newfile");
458: if(!(defined $newfh)){
459: return 0;
460: }
461: my $lines = scalar @contents;
462: for (my $i =0; $i < $lines; $i++) {
463: print $newfh ($contents[$i]);
464: }
465:
466: $oldfh->close;
467: $newfh->close;
468:
469: chmod(0660, $newfile);
470:
471: return 1;
472:
473: } else {
474: return 0;
475: }
476: }
1.157 foxr 477: #
478: # Host files are passed out with externally visible host IPs.
479: # If, for example, we are behind a fire-wall or NAT host, our
480: # internally visible IP may be different than the externally
481: # visible IP. Therefore, we always adjust the contents of the
482: # host file so that the entry for ME is the IP that we believe
483: # we have. At present, this is defined as the entry that
484: # DNS has for us. If by some chance we are not able to get a
485: # DNS translation for us, then we assume that the host.tab file
486: # is correct.
487: # BUGBUGBUG - in the future, we really should see if we can
488: # easily query the interface(s) instead.
489: # Parameter(s):
490: # contents - The contents of the host.tab to check.
491: # Returns:
492: # newcontents - The adjusted contents.
493: #
494: #
495: sub AdjustHostContents {
496: my $contents = shift;
497: my $adjusted;
498: my $me = $perlvar{'lonHostID'};
499:
1.166 foxr 500: foreach my $line (split(/\n/,$contents)) {
1.157 foxr 501: if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
502: chomp($line);
503: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
504: if ($id eq $me) {
1.166 foxr 505: my $ip = gethostbyname($name);
506: my $ipnew = inet_ntoa($ip);
507: $ip = $ipnew;
1.157 foxr 508: # Reconstruct the host line and append to adjusted:
509:
1.166 foxr 510: my $newline = "$id:$domain:$role:$name:$ip";
511: if($maxcon ne "") { # Not all hosts have loncnew tuning params
512: $newline .= ":$maxcon:$idleto:$mincon";
513: }
514: $adjusted .= $newline."\n";
1.157 foxr 515:
1.166 foxr 516: } else { # Not me, pass unmodified.
517: $adjusted .= $line."\n";
518: }
1.157 foxr 519: } else { # Blank or comment never re-written.
520: $adjusted .= $line."\n"; # Pass blanks and comments as is.
521: }
1.166 foxr 522: }
523: return $adjusted;
1.157 foxr 524: }
1.143 foxr 525: #
526: # InstallFile: Called to install an administrative file:
527: # - The file is created with <name>.tmp
528: # - The <name>.tmp file is then mv'd to <name>
529: # This lugubrious procedure is done to ensure that we are never without
530: # a valid, even if dated, version of the file regardless of who crashes
531: # and when the crash occurs.
532: #
533: # Parameters:
534: # Name of the file
535: # File Contents.
536: # Return:
537: # nonzero - success.
538: # 0 - failure and $! has an errno.
539: #
540: sub InstallFile {
1.192 foxr 541:
542: my ($Filename, $Contents) = @_;
1.143 foxr 543: my $TempFile = $Filename.".tmp";
544:
545: # Open the file for write:
546:
547: my $fh = IO::File->new("> $TempFile"); # Write to temp.
548: if(!(defined $fh)) {
549: &logthis('<font color="red"> Unable to create '.$TempFile."</font>");
550: return 0;
551: }
552: # write the contents of the file:
553:
554: print $fh ($Contents);
555: $fh->close; # In case we ever have a filesystem w. locking
556:
557: chmod(0660, $TempFile);
558:
559: # Now we can move install the file in position.
560:
561: move($TempFile, $Filename);
562:
563: return 1;
564: }
1.200 matthew 565:
566:
1.169 foxr 567: #
568: # ConfigFileFromSelector: converts a configuration file selector
569: # (one of host or domain at this point) into a
570: # configuration file pathname.
571: #
572: # Parameters:
573: # selector - Configuration file selector.
574: # Returns:
575: # Full path to the file or undef if the selector is invalid.
576: #
577: sub ConfigFileFromSelector {
578: my $selector = shift;
579: my $tablefile;
580:
581: my $tabledir = $perlvar{'lonTabDir'}.'/';
582: if ($selector eq "hosts") {
583: $tablefile = $tabledir."hosts.tab";
584: } elsif ($selector eq "domain") {
585: $tablefile = $tabledir."domain.tab";
586: } else {
587: return undef;
588: }
589: return $tablefile;
1.143 foxr 590:
1.169 foxr 591: }
1.143 foxr 592: #
1.141 foxr 593: # PushFile: Called to do an administrative push of a file.
594: # - Ensure the file being pushed is one we support.
595: # - Backup the old file to <filename.saved>
596: # - Separate the contents of the new file out from the
597: # rest of the request.
598: # - Write the new file.
599: # Parameter:
600: # Request - The entire user request. This consists of a : separated
601: # string pushfile:tablename:contents.
602: # NOTE: The contents may have :'s in it as well making things a bit
603: # more interesting... but not much.
604: # Returns:
605: # String to send to client ("ok" or "refused" if bad file).
606: #
607: sub PushFile {
608: my $request = shift;
609: my ($command, $filename, $contents) = split(":", $request, 3);
610:
611: # At this point in time, pushes for only the following tables are
612: # supported:
613: # hosts.tab ($filename eq host).
614: # domain.tab ($filename eq domain).
615: # Construct the destination filename or reject the request.
616: #
617: # lonManage is supposed to ensure this, however this session could be
618: # part of some elaborate spoof that managed somehow to authenticate.
619: #
620:
1.169 foxr 621:
622: my $tablefile = ConfigFileFromSelector($filename);
623: if(! (defined $tablefile)) {
1.141 foxr 624: return "refused";
625: }
626: #
627: # >copy< the old table to the backup table
628: # don't rename in case system crashes/reboots etc. in the time
629: # window between a rename and write.
630: #
631: my $backupfile = $tablefile;
632: $backupfile =~ s/\.tab$/.old/;
1.143 foxr 633: if(!CopyFile($tablefile, $backupfile)) {
634: &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
635: return "error:$!";
636: }
1.141 foxr 637: &logthis('<font color="green"> Pushfile: backed up '
638: .$tablefile." to $backupfile</font>");
639:
1.157 foxr 640: # If the file being pushed is the host file, we adjust the entry for ourself so that the
641: # IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible
642: # to conceive of conditions where we don't have a DNS entry locally. This is possible in a
643: # network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now)
644: # that possibilty.
645:
646: if($filename eq "host") {
647: $contents = AdjustHostContents($contents);
648: }
649:
1.141 foxr 650: # Install the new file:
651:
1.143 foxr 652: if(!InstallFile($tablefile, $contents)) {
653: &logthis('<font color="red"> Pushfile: unable to install '
1.145 foxr 654: .$tablefile." $! </font>");
1.143 foxr 655: return "error:$!";
656: }
657: else {
658: &logthis('<font color="green"> Installed new '.$tablefile
659: ."</font>");
660:
661: }
662:
1.141 foxr 663:
664: # Indicate success:
665:
666: return "ok";
667:
668: }
1.145 foxr 669:
670: #
671: # Called to re-init either lonc or lond.
672: #
673: # Parameters:
674: # request - The full request by the client. This is of the form
675: # reinit:<process>
676: # where <process> is allowed to be either of
677: # lonc or lond
678: #
679: # Returns:
680: # The string to be sent back to the client either:
681: # ok - Everything worked just fine.
682: # error:why - There was a failure and why describes the reason.
683: #
684: #
685: sub ReinitProcess {
686: my $request = shift;
687:
1.146 foxr 688:
689: # separate the request (reinit) from the process identifier and
690: # validate it producing the name of the .pid file for the process.
691: #
692: #
693: my ($junk, $process) = split(":", $request);
1.147 foxr 694: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
1.146 foxr 695: if($process eq 'lonc') {
696: $processpidfile = $processpidfile."lonc.pid";
1.147 foxr 697: if (!open(PIDFILE, "< $processpidfile")) {
698: return "error:Open failed for $processpidfile";
699: }
700: my $loncpid = <PIDFILE>;
701: close(PIDFILE);
702: logthis('<font color="red"> Reinitializing lonc pid='.$loncpid
703: ."</font>");
704: kill("USR2", $loncpid);
1.146 foxr 705: } elsif ($process eq 'lond') {
1.147 foxr 706: logthis('<font color="red"> Reinitializing self (lond) </font>');
707: &UpdateHosts; # Lond is us!!
1.146 foxr 708: } else {
709: &logthis('<font color="yellow" Invalid reinit request for '.$process
710: ."</font>");
711: return "error:Invalid process identifier $process";
712: }
1.145 foxr 713: return 'ok';
714: }
1.168 foxr 715: # Validate a line in a configuration file edit script:
716: # Validation includes:
717: # - Ensuring the command is valid.
718: # - Ensuring the command has sufficient parameters
719: # Parameters:
720: # scriptline - A line to validate (\n has been stripped for what it's worth).
1.167 foxr 721: #
1.168 foxr 722: # Return:
723: # 0 - Invalid scriptline.
724: # 1 - Valid scriptline
725: # NOTE:
726: # Only the command syntax is checked, not the executability of the
727: # command.
728: #
729: sub isValidEditCommand {
730: my $scriptline = shift;
731:
732: # Line elements are pipe separated:
733:
734: my ($command, $key, $newline) = split(/\|/, $scriptline);
735: &logthis('<font color="green"> isValideditCommand checking: '.
736: "Command = '$command', Key = '$key', Newline = '$newline' </font>\n");
737:
738: if ($command eq "delete") {
739: #
740: # key with no newline.
741: #
742: if( ($key eq "") || ($newline ne "")) {
743: return 0; # Must have key but no newline.
744: } else {
745: return 1; # Valid syntax.
746: }
1.169 foxr 747: } elsif ($command eq "replace") {
1.168 foxr 748: #
749: # key and newline:
750: #
751: if (($key eq "") || ($newline eq "")) {
752: return 0;
753: } else {
754: return 1;
755: }
1.169 foxr 756: } elsif ($command eq "append") {
757: if (($key ne "") && ($newline eq "")) {
758: return 1;
759: } else {
760: return 0;
761: }
1.168 foxr 762: } else {
763: return 0; # Invalid command.
764: }
765: return 0; # Should not get here!!!
766: }
1.169 foxr 767: #
768: # ApplyEdit - Applies an edit command to a line in a configuration
769: # file. It is the caller's responsiblity to validate the
770: # edit line.
771: # Parameters:
772: # $directive - A single edit directive to apply.
773: # Edit directives are of the form:
774: # append|newline - Appends a new line to the file.
775: # replace|key|newline - Replaces the line with key value 'key'
776: # delete|key - Deletes the line with key value 'key'.
777: # $editor - A config file editor object that contains the
778: # file being edited.
779: #
780: sub ApplyEdit {
1.192 foxr 781:
782: my ($directive, $editor) = @_;
1.169 foxr 783:
784: # Break the directive down into its command and its parameters
785: # (at most two at this point. The meaning of the parameters, if in fact
786: # they exist depends on the command).
787:
788: my ($command, $p1, $p2) = split(/\|/, $directive);
789:
790: if($command eq "append") {
791: $editor->Append($p1); # p1 - key p2 null.
792: } elsif ($command eq "replace") {
793: $editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline.
794: } elsif ($command eq "delete") {
795: $editor->DeleteLine($p1); # p1 - key p2 null.
796: } else { # Should not get here!!!
797: die "Invalid command given to ApplyEdit $command"
798: }
799: }
800: #
801: # AdjustOurHost:
802: # Adjusts a host file stored in a configuration file editor object
803: # for the true IP address of this host. This is necessary for hosts
804: # that live behind a firewall.
805: # Those hosts have a publicly distributed IP of the firewall, but
806: # internally must use their actual IP. We assume that a given
807: # host only has a single IP interface for now.
808: # Formal Parameters:
809: # editor - The configuration file editor to adjust. This
810: # editor is assumed to contain a hosts.tab file.
811: # Strategy:
812: # - Figure out our hostname.
813: # - Lookup the entry for this host.
814: # - Modify the line to contain our IP
815: # - Do a replace for this host.
816: sub AdjustOurHost {
817: my $editor = shift;
818:
819: # figure out who I am.
820:
821: my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname.
822:
823: # Get my host file entry.
824:
825: my $ConfigLine = $editor->Find($myHostName);
826: if(! (defined $ConfigLine)) {
827: die "AdjustOurHost - no entry for me in hosts file $myHostName";
828: }
829: # figure out my IP:
830: # Use the config line to get my hostname.
831: # Use gethostbyname to translate that into an IP address.
832: #
833: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
834: my $BinaryIp = gethostbyname($name);
835: my $ip = inet_ntoa($ip);
836: #
837: # Reassemble the config line from the elements in the list.
838: # Note that if the loncnew items were not present before, they will
839: # be now even if they would be empty
840: #
841: my $newConfigLine = $id;
842: foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {
843: $newConfigLine .= ":".$item;
844: }
845: # Replace the line:
846:
847: $editor->ReplaceLine($id, $newConfigLine);
848:
849: }
850: #
851: # ReplaceConfigFile:
852: # Replaces a configuration file with the contents of a
853: # configuration file editor object.
854: # This is done by:
855: # - Copying the target file to <filename>.old
856: # - Writing the new file to <filename>.tmp
857: # - Moving <filename.tmp> -> <filename>
858: # This laborious process ensures that the system is never without
859: # a configuration file that's at least valid (even if the contents
860: # may be dated).
861: # Parameters:
862: # filename - Name of the file to modify... this is a full path.
863: # editor - Editor containing the file.
864: #
865: sub ReplaceConfigFile {
1.192 foxr 866:
867: my ($filename, $editor) = @_;
1.168 foxr 868:
1.169 foxr 869: CopyFile ($filename, $filename.".old");
870:
871: my $contents = $editor->Get(); # Get the contents of the file.
872:
873: InstallFile($filename, $contents);
874: }
1.168 foxr 875: #
876: #
877: # Called to edit a configuration table file
1.167 foxr 878: # Parameters:
879: # request - The entire command/request sent by lonc or lonManage
880: # Return:
881: # The reply to send to the client.
1.168 foxr 882: #
1.167 foxr 883: sub EditFile {
884: my $request = shift;
885:
886: # Split the command into it's pieces: edit:filetype:script
887:
1.168 foxr 888: my ($request, $filetype, $script) = split(/:/, $request,3); # : in script
1.167 foxr 889:
890: # Check the pre-coditions for success:
891:
892: if($request != "edit") { # Something is amiss afoot alack.
893: return "error:edit request detected, but request != 'edit'\n";
894: }
895: if( ($filetype ne "hosts") &&
896: ($filetype ne "domain")) {
897: return "error:edit requested with invalid file specifier: $filetype \n";
898: }
899:
900: # Split the edit script and check it's validity.
1.168 foxr 901:
902: my @scriptlines = split(/\n/, $script); # one line per element.
903: my $linecount = scalar(@scriptlines);
904: for(my $i = 0; $i < $linecount; $i++) {
905: chomp($scriptlines[$i]);
906: if(!isValidEditCommand($scriptlines[$i])) {
907: return "error:edit with bad script line: '$scriptlines[$i]' \n";
908: }
909: }
1.145 foxr 910:
1.167 foxr 911: # Execute the edit operation.
1.169 foxr 912: # - Create a config file editor for the appropriate file and
913: # - execute each command in the script:
914: #
915: my $configfile = ConfigFileFromSelector($filetype);
916: if (!(defined $configfile)) {
917: return "refused\n";
918: }
919: my $editor = ConfigFileEdit->new($configfile);
1.167 foxr 920:
1.169 foxr 921: for (my $i = 0; $i < $linecount; $i++) {
922: ApplyEdit($scriptlines[$i], $editor);
923: }
924: # If the file is the host file, ensure that our host is
925: # adjusted to have our ip:
926: #
927: if($filetype eq "host") {
928: AdjustOurHost($editor);
929: }
930: # Finally replace the current file with our file.
931: #
932: ReplaceConfigFile($configfile, $editor);
1.167 foxr 933:
934: return "ok\n";
935: }
1.207 foxr 936:
937: #---------------------------------------------------------------
938: #
939: # Manipulation of hash based databases (factoring out common code
940: # for later use as we refactor.
941: #
942: # Ties a domain level resource file to a hash.
943: # If requested a history entry is created in the associated hist file.
944: #
945: # Parameters:
946: # domain - Name of the domain in which the resource file lives.
947: # namespace - Name of the hash within that domain.
948: # how - How to tie the hash (e.g. GDBM_WRCREAT()).
949: # loghead - Optional parameter, if present a log entry is created
950: # in the associated history file and this is the first part
951: # of that entry.
952: # logtail - Goes along with loghead, The actual logentry is of the
953: # form $loghead:<timestamp>:logtail.
954: # Returns:
955: # Reference to a hash bound to the db file or alternatively undef
956: # if the tie failed.
957: #
1.209 ! albertel 958: sub tie_domain_hash {
1.207 foxr 959: my ($domain,
960: $namespace,
961: $how) = @_;
962:
963: # Filter out any whitespace in the domain name:
964:
965: $domain =~ s/\W//g;
966:
967: # We have enough to go on to tie the hash:
968:
969: my $user_top_dir = $perlvar{'lonUsersDir'};
970: my $domain_dir = $user_top_dir."/$domain";
971: my $resource_file = $domain_dir."/$namespace.db";
972: my %hash;
973: if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) {
974: if (scalar @_) { # Need to log the operation.
975: my $logFh = IO::File->new(">>domain_dir/$namespace.hist");
976: if($logFh) {
977: my $timestamp = time;
978: my ($loghead, $logtail) = @_;
979: print $logFh "$loghead:$timestamp:$logtail\n";
980: }
981: }
982: return \%hash; # Return the tied hash.
983: }
984: else {
985: return undef; # Tie failed.
986: }
987: }
988:
989: #
990: # Ties a user's resource file to a hash.
991: # If necessary, an appropriate history
992: # log file entry is made as well.
993: # This sub factors out common code from the subs that manipulate
994: # the various gdbm files that keep keyword value pairs.
995: # Parameters:
996: # domain - Name of the domain the user is in.
997: # user - Name of the 'current user'.
998: # namespace - Namespace representing the file to tie.
999: # how - What the tie is done to (e.g. GDBM_WRCREAT().
1000: # loghead - Optional first part of log entry if there may be a
1001: # history file.
1002: # what - Optional tail of log entry if there may be a history
1003: # file.
1004: # Returns:
1005: # hash to which the database is tied. It's up to the caller to untie.
1006: # undef if the has could not be tied.
1007: #
1008: sub TieUserHash {
1009: my ($domain,
1010: $user,
1011: $namespace,
1012: $how) = @_;
1013:
1014:
1015: $namespace=~s/\//\_/g; # / -> _
1016: $namespace=~s/\W//g; # whitespace eliminated.
1017: my $proname = propath($domain, $user);
1018:
1019: # Tie the database.
1020:
1021: my %hash;
1022: if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
1023: $how, 0640)) {
1.209 ! albertel 1024: # If this is a namespace for which a history is kept,
! 1025: # make the history log entry:
! 1026: if (($namespace =~/^nohist\_/) && (scalar @_ > 0)) {
! 1027: my $args = scalar @_;
! 1028: Debug(" Opening history: $namespace $args");
! 1029: my $hfh = IO::File->new(">>$proname/$namespace.hist");
! 1030: if($hfh) {
! 1031: my $now = time;
! 1032: my $loghead = shift;
! 1033: my $what = shift;
! 1034: print $hfh "$loghead:$now:$what\n";
! 1035: }
! 1036: }
1.207 foxr 1037: return \%hash;
1.209 ! albertel 1038: } else {
1.207 foxr 1039: return undef;
1040: }
1041:
1042: }
1043: #---------------------------------------------------------------
1044: #
1045: # Getting, decoding and dispatching requests:
1046: #
1047:
1048: #
1049: # Get a Request:
1050: # Gets a Request message from the client. The transaction
1051: # is defined as a 'line' of text. We remove the new line
1052: # from the text line.
1053: #
1054: sub GetRequest {
1055: my $input = <$client>;
1056: chomp($input);
1057:
1058: Debug("Request = $input\n");
1059:
1060: &status('Processing '.$clientname.':'.$input);
1061:
1062: return $input;
1063: }
1064: #
1065: # Decipher encoded traffic
1066: # Parameters:
1067: # input - Encoded data.
1068: # Returns:
1069: # Decoded data or undef if encryption key was not yet negotiated.
1070: # Implicit input:
1071: # cipher - This global holds the negotiated encryption key.
1072: #
1073: sub Decipher {
1074: my ($input) = @_;
1075: my $output = '';
1076:
1077:
1078: if($cipher) {
1079: my($enc, $enclength, $encinput) = split(/:/, $input);
1080: for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {
1081: $output .=
1082: $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));
1083: }
1084: return substr($output, 0, $enclength);
1085: } else {
1086: return undef;
1087: }
1088: }
1089:
1090: #
1091: # Register a command processor. This function is invoked to register a sub
1092: # to process a request. Once registered, the ProcessRequest sub can automatically
1093: # dispatch requests to an appropriate sub, and do the top level validity checking
1094: # as well:
1095: # - Is the keyword recognized.
1096: # - Is the proper client type attempting the request.
1097: # - Is the request encrypted if it has to be.
1098: # Parameters:
1099: # $request_name - Name of the request being registered.
1100: # This is the command request that will match
1101: # against the hash keywords to lookup the information
1102: # associated with the dispatch information.
1103: # $procedure - Reference to a sub to call to process the request.
1104: # All subs get called as follows:
1105: # Procedure($cmd, $tail, $replyfd, $key)
1106: # $cmd - the actual keyword that invoked us.
1107: # $tail - the tail of the request that invoked us.
1108: # $replyfd- File descriptor connected to the client
1109: # $must_encode - True if the request must be encoded to be good.
1110: # $client_ok - True if it's ok for a client to request this.
1111: # $manager_ok - True if it's ok for a manager to request this.
1112: # Side effects:
1113: # - On success, the Dispatcher hash has an entry added for the key $RequestName
1114: # - On failure, the program will die as it's a bad internal bug to try to
1115: # register a duplicate command handler.
1116: #
1117: sub RegisterHandler {
1118: my ($request_name,
1119: $procedure,
1120: $must_encode,
1121: $client_ok,
1122: $manager_ok) = @_;
1123:
1124: # Don't allow duplication#
1125:
1126: if (defined $Dispatcher{$request_name}) {
1127: die "Attempting to define a duplicate request handler for $request_name\n";
1128: }
1129: # Build the client type mask:
1130:
1131: my $client_type_mask = 0;
1132: if($client_ok) {
1133: $client_type_mask |= $CLIENT_OK;
1134: }
1135: if($manager_ok) {
1136: $client_type_mask |= $MANAGER_OK;
1137: }
1138:
1139: # Enter the hash:
1140:
1141: my @entry = ($procedure, $must_encode, $client_type_mask);
1142:
1143: $Dispatcher{$request_name} = \@entry;
1144:
1145:
1146: }
1147:
1148:
1149: #------------------------------------------------------------------
1150:
1151:
1152:
1153:
1.141 foxr 1154: #
1.96 foxr 1155: # Convert an error return code from lcpasswd to a string value.
1156: #
1157: sub lcpasswdstrerror {
1158: my $ErrorCode = shift;
1.97 foxr 1159: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
1.96 foxr 1160: return "lcpasswd Unrecognized error return value ".$ErrorCode;
1161: } else {
1.98 foxr 1162: return $passwderrors[$ErrorCode];
1.96 foxr 1163: }
1164: }
1165:
1.97 foxr 1166: #
1167: # Convert an error return code from lcuseradd to a string value:
1168: #
1169: sub lcuseraddstrerror {
1170: my $ErrorCode = shift;
1171: if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
1172: return "lcuseradd - Unrecognized error code: ".$ErrorCode;
1173: } else {
1.98 foxr 1174: return $adderrors[$ErrorCode];
1.97 foxr 1175: }
1176: }
1177:
1.23 harris41 1178: # grabs exception and records it to log before exiting
1179: sub catchexception {
1.27 albertel 1180: my ($error)=@_;
1.25 www 1181: $SIG{'QUIT'}='DEFAULT';
1182: $SIG{__DIE__}='DEFAULT';
1.165 albertel 1183: &status("Catching exception");
1.190 albertel 1184: &logthis("<font color='red'>CRITICAL: "
1.134 albertel 1185: ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
1.27 albertel 1186: ."a crash with this error msg->[$error]</font>");
1.57 www 1187: &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27 albertel 1188: if ($client) { print $client "error: $error\n"; }
1.59 www 1189: $server->close();
1.27 albertel 1190: die($error);
1.23 harris41 1191: }
1192:
1.63 www 1193: sub timeout {
1.165 albertel 1194: &status("Handling Timeout");
1.190 albertel 1195: &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
1.63 www 1196: &catchexception('Timeout');
1197: }
1.22 harris41 1198: # -------------------------------- Set signal handlers to record abnormal exits
1199:
1200: $SIG{'QUIT'}=\&catchexception;
1201: $SIG{__DIE__}=\&catchexception;
1202:
1.81 matthew 1203: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
1.95 harris41 1204: &status("Read loncapa.conf and loncapa_apache.conf");
1205: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.141 foxr 1206: %perlvar=%{$perlvarref};
1.80 harris41 1207: undef $perlvarref;
1.19 www 1208:
1.35 harris41 1209: # ----------------------------- Make sure this process is running from user=www
1210: my $wwwid=getpwnam('www');
1211: if ($wwwid!=$<) {
1.134 albertel 1212: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
1213: my $subj="LON: $currenthostid User ID mismatch";
1.37 harris41 1214: system("echo 'User ID mismatch. lond must be run as user www.' |\
1.35 harris41 1215: mailto $emailto -s '$subj' > /dev/null");
1216: exit 1;
1217: }
1218:
1.19 www 1219: # --------------------------------------------- Check if other instance running
1220:
1221: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
1222:
1223: if (-e $pidfile) {
1224: my $lfh=IO::File->new("$pidfile");
1225: my $pide=<$lfh>;
1226: chomp($pide);
1.29 harris41 1227: if (kill 0 => $pide) { die "already running"; }
1.19 www 1228: }
1.1 albertel 1229:
1230: # ------------------------------------------------------------- Read hosts file
1231:
1232:
1233:
1234: # establish SERVER socket, bind and listen.
1235: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
1236: Type => SOCK_STREAM,
1237: Proto => 'tcp',
1238: Reuse => 1,
1239: Listen => 10 )
1.29 harris41 1240: or die "making socket: $@\n";
1.1 albertel 1241:
1242: # --------------------------------------------------------- Do global variables
1243:
1244: # global variables
1245:
1.134 albertel 1246: my %children = (); # keys are current child process IDs
1.1 albertel 1247:
1248: sub REAPER { # takes care of dead children
1249: $SIG{CHLD} = \&REAPER;
1.165 albertel 1250: &status("Handling child death");
1.178 foxr 1251: my $pid;
1252: do {
1253: $pid = waitpid(-1,&WNOHANG());
1254: if (defined($children{$pid})) {
1255: &logthis("Child $pid died");
1256: delete($children{$pid});
1.183 albertel 1257: } elsif ($pid > 0) {
1.178 foxr 1258: &logthis("Unknown Child $pid died");
1259: }
1260: } while ( $pid > 0 );
1261: foreach my $child (keys(%children)) {
1262: $pid = waitpid($child,&WNOHANG());
1263: if ($pid > 0) {
1264: &logthis("Child $child - $pid looks like we missed it's death");
1265: delete($children{$pid});
1266: }
1.176 albertel 1267: }
1.165 albertel 1268: &status("Finished Handling child death");
1.1 albertel 1269: }
1270:
1271: sub HUNTSMAN { # signal handler for SIGINT
1.165 albertel 1272: &status("Killing children (INT)");
1.1 albertel 1273: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
1274: kill 'INT' => keys %children;
1.59 www 1275: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1 albertel 1276: my $execdir=$perlvar{'lonDaemons'};
1277: unlink("$execdir/logs/lond.pid");
1.190 albertel 1278: &logthis("<font color='red'>CRITICAL: Shutting down</font>");
1.165 albertel 1279: &status("Done killing children");
1.1 albertel 1280: exit; # clean up with dignity
1281: }
1282:
1283: sub HUPSMAN { # signal handler for SIGHUP
1284: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
1.165 albertel 1285: &status("Killing children for restart (HUP)");
1.1 albertel 1286: kill 'INT' => keys %children;
1.59 www 1287: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.190 albertel 1288: &logthis("<font color='red'>CRITICAL: Restarting</font>");
1.134 albertel 1289: my $execdir=$perlvar{'lonDaemons'};
1.30 harris41 1290: unlink("$execdir/logs/lond.pid");
1.165 albertel 1291: &status("Restarting self (HUP)");
1.1 albertel 1292: exec("$execdir/lond"); # here we go again
1293: }
1294:
1.144 foxr 1295: #
1.148 foxr 1296: # Kill off hashes that describe the host table prior to re-reading it.
1297: # Hashes affected are:
1.200 matthew 1298: # %hostid, %hostdom %hostip %hostdns.
1.148 foxr 1299: #
1300: sub KillHostHashes {
1301: foreach my $key (keys %hostid) {
1302: delete $hostid{$key};
1303: }
1304: foreach my $key (keys %hostdom) {
1305: delete $hostdom{$key};
1306: }
1307: foreach my $key (keys %hostip) {
1308: delete $hostip{$key};
1309: }
1.200 matthew 1310: foreach my $key (keys %hostdns) {
1311: delete $hostdns{$key};
1312: }
1.148 foxr 1313: }
1314: #
1315: # Read in the host table from file and distribute it into the various hashes:
1316: #
1317: # - %hostid - Indexed by IP, the loncapa hostname.
1318: # - %hostdom - Indexed by loncapa hostname, the domain.
1319: # - %hostip - Indexed by hostid, the Ip address of the host.
1320: sub ReadHostTable {
1321:
1322: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
1.200 matthew 1323: my $myloncapaname = $perlvar{'lonHostID'};
1324: Debug("My loncapa name is : $myloncapaname");
1.148 foxr 1325: while (my $configline=<CONFIG>) {
1.178 foxr 1326: if (!($configline =~ /^\s*\#/)) {
1327: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
1328: chomp($ip); $ip=~s/\D+$//;
1.200 matthew 1329: $hostid{$ip}=$id; # LonCAPA name of host by IP.
1330: $hostdom{$id}=$domain; # LonCAPA domain name of host.
1331: $hostip{$id}=$ip; # IP address of host.
1332: $hostdns{$name} = $id; # LonCAPA name of host by DNS.
1333:
1334: if ($id eq $perlvar{'lonHostID'}) {
1335: Debug("Found me in the host table: $name");
1336: $thisserver=$name;
1337: }
1.178 foxr 1338: }
1.148 foxr 1339: }
1340: close(CONFIG);
1341: }
1342: #
1343: # Reload the Apache daemon's state.
1.150 foxr 1344: # This is done by invoking /home/httpd/perl/apachereload
1345: # a setuid perl script that can be root for us to do this job.
1.148 foxr 1346: #
1347: sub ReloadApache {
1.150 foxr 1348: my $execdir = $perlvar{'lonDaemons'};
1349: my $script = $execdir."/apachereload";
1350: system($script);
1.148 foxr 1351: }
1352:
1353: #
1.144 foxr 1354: # Called in response to a USR2 signal.
1355: # - Reread hosts.tab
1356: # - All children connected to hosts that were removed from hosts.tab
1357: # are killed via SIGINT
1358: # - All children connected to previously existing hosts are sent SIGUSR1
1359: # - Our internal hosts hash is updated to reflect the new contents of
1360: # hosts.tab causing connections from hosts added to hosts.tab to
1361: # now be honored.
1362: #
1363: sub UpdateHosts {
1.165 albertel 1364: &status("Reload hosts.tab");
1.147 foxr 1365: logthis('<font color="blue"> Updating connections </font>');
1.148 foxr 1366: #
1367: # The %children hash has the set of IP's we currently have children
1368: # on. These need to be matched against records in the hosts.tab
1369: # Any ip's no longer in the table get killed off they correspond to
1370: # either dropped or changed hosts. Note that the re-read of the table
1371: # will take care of new and changed hosts as connections come into being.
1372:
1373:
1374: KillHostHashes;
1375: ReadHostTable;
1376:
1377: foreach my $child (keys %children) {
1378: my $childip = $children{$child};
1379: if(!$hostid{$childip}) {
1.149 foxr 1380: logthis('<font color="blue"> UpdateHosts killing child '
1381: ." $child for ip $childip </font>");
1.148 foxr 1382: kill('INT', $child);
1.149 foxr 1383: } else {
1384: logthis('<font color="green"> keeping child for ip '
1385: ." $childip (pid=$child) </font>");
1.148 foxr 1386: }
1387: }
1388: ReloadApache;
1.165 albertel 1389: &status("Finished reloading hosts.tab");
1.144 foxr 1390: }
1391:
1.148 foxr 1392:
1.57 www 1393: sub checkchildren {
1.165 albertel 1394: &status("Checking on the children (sending signals)");
1.57 www 1395: &initnewstatus();
1396: &logstatus();
1397: &logthis('Going to check on the children');
1.134 albertel 1398: my $docdir=$perlvar{'lonDocRoot'};
1.61 harris41 1399: foreach (sort keys %children) {
1.57 www 1400: sleep 1;
1401: unless (kill 'USR1' => $_) {
1402: &logthis ('Child '.$_.' is dead');
1403: &logstatus($$.' is dead');
1404: }
1.61 harris41 1405: }
1.63 www 1406: sleep 5;
1.113 albertel 1407: $SIG{ALRM} = sub { die "timeout" };
1408: $SIG{__DIE__} = 'DEFAULT';
1.165 albertel 1409: &status("Checking on the children (waiting for reports)");
1.63 www 1410: foreach (sort keys %children) {
1411: unless (-e "$docdir/lon-status/londchld/$_.txt") {
1.113 albertel 1412: eval {
1413: alarm(300);
1.63 www 1414: &logthis('Child '.$_.' did not respond');
1.67 albertel 1415: kill 9 => $_;
1.131 albertel 1416: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
1417: #$subj="LON: $currenthostid killed lond process $_";
1418: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
1419: #$execdir=$perlvar{'lonDaemons'};
1420: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
1.113 albertel 1421: alarm(0);
1422: }
1.63 www 1423: }
1424: }
1.113 albertel 1425: $SIG{ALRM} = 'DEFAULT';
1.155 albertel 1426: $SIG{__DIE__} = \&catchexception;
1.165 albertel 1427: &status("Finished checking children");
1.57 www 1428: }
1429:
1.1 albertel 1430: # --------------------------------------------------------------------- Logging
1431:
1432: sub logthis {
1433: my $message=shift;
1434: my $execdir=$perlvar{'lonDaemons'};
1435: my $fh=IO::File->new(">>$execdir/logs/lond.log");
1436: my $now=time;
1437: my $local=localtime($now);
1.58 www 1438: $lastlog=$local.': '.$message;
1.1 albertel 1439: print $fh "$local ($$): $message\n";
1440: }
1441:
1.77 foxr 1442: # ------------------------- Conditional log if $DEBUG true.
1443: sub Debug {
1444: my $message = shift;
1445: if($DEBUG) {
1446: &logthis($message);
1447: }
1448: }
1.161 foxr 1449:
1450: #
1451: # Sub to do replies to client.. this gives a hook for some
1452: # debug tracing too:
1453: # Parameters:
1454: # fd - File open on client.
1455: # reply - Text to send to client.
1456: # request - Original request from client.
1457: #
1458: sub Reply {
1.192 foxr 1459:
1460: my ($fd, $reply, $request) = @_;
1.161 foxr 1461:
1462: print $fd $reply;
1463: Debug("Request was $request Reply was $reply");
1464:
1465: }
1.57 www 1466: # ------------------------------------------------------------------ Log status
1467:
1468: sub logstatus {
1.178 foxr 1469: &status("Doing logging");
1470: my $docdir=$perlvar{'lonDocRoot'};
1471: {
1472: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
1.200 matthew 1473: print $fh $$."\t".$clientname."\t".$currenthostid."\t"
1474: .$status."\t".$lastlog."\t $keymode\n";
1.178 foxr 1475: $fh->close();
1476: }
1477: &status("Finished londstatus.txt");
1478: {
1479: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
1.200 matthew 1480: print $fh $status."\n".$lastlog."\n".time."\n$keymode";
1.178 foxr 1481: $fh->close();
1482: }
1483: &status("Finished logging");
1.57 www 1484: }
1485:
1486: sub initnewstatus {
1487: my $docdir=$perlvar{'lonDocRoot'};
1488: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
1489: my $now=time;
1490: my $local=localtime($now);
1491: print $fh "LOND status $local - parent $$\n\n";
1.64 www 1492: opendir(DIR,"$docdir/lon-status/londchld");
1.134 albertel 1493: while (my $filename=readdir(DIR)) {
1.64 www 1494: unlink("$docdir/lon-status/londchld/$filename");
1495: }
1496: closedir(DIR);
1.57 www 1497: }
1498:
1499: # -------------------------------------------------------------- Status setting
1500:
1501: sub status {
1502: my $what=shift;
1503: my $now=time;
1504: my $local=localtime($now);
1.178 foxr 1505: $status=$local.': '.$what;
1506: $0='lond: '.$what.' '.$local;
1.57 www 1507: }
1.11 www 1508:
1509: # -------------------------------------------------------- Escape Special Chars
1510:
1511: sub escape {
1512: my $str=shift;
1513: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
1514: return $str;
1515: }
1516:
1517: # ----------------------------------------------------- Un-Escape Special Chars
1518:
1519: sub unescape {
1520: my $str=shift;
1521: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1522: return $str;
1523: }
1524:
1.1 albertel 1525: # ----------------------------------------------------------- Send USR1 to lonc
1526:
1527: sub reconlonc {
1528: my $peerfile=shift;
1529: &logthis("Trying to reconnect for $peerfile");
1530: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
1531: if (my $fh=IO::File->new("$loncfile")) {
1532: my $loncpid=<$fh>;
1533: chomp($loncpid);
1534: if (kill 0 => $loncpid) {
1535: &logthis("lonc at pid $loncpid responding, sending USR1");
1536: kill USR1 => $loncpid;
1537: } else {
1.9 www 1538: &logthis(
1.190 albertel 1539: "<font color='red'>CRITICAL: "
1.9 www 1540: ."lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 1541: }
1542: } else {
1.190 albertel 1543: &logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
1.1 albertel 1544: }
1545: }
1546:
1547: # -------------------------------------------------- Non-critical communication
1.11 www 1548:
1.1 albertel 1549: sub subreply {
1550: my ($cmd,$server)=@_;
1551: my $peerfile="$perlvar{'lonSockDir'}/$server";
1552: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
1553: Type => SOCK_STREAM,
1554: Timeout => 10)
1555: or return "con_lost";
1556: print $sclient "$cmd\n";
1557: my $answer=<$sclient>;
1558: chomp($answer);
1559: if (!$answer) { $answer="con_lost"; }
1560: return $answer;
1561: }
1562:
1563: sub reply {
1564: my ($cmd,$server)=@_;
1565: my $answer;
1.115 albertel 1566: if ($server ne $currenthostid) {
1.1 albertel 1567: $answer=subreply($cmd,$server);
1568: if ($answer eq 'con_lost') {
1569: $answer=subreply("ping",$server);
1570: if ($answer ne $server) {
1.115 albertel 1571: &logthis("sub reply: answer != server answer is $answer, server is $server");
1.1 albertel 1572: &reconlonc("$perlvar{'lonSockDir'}/$server");
1573: }
1574: $answer=subreply($cmd,$server);
1575: }
1576: } else {
1577: $answer='self_reply';
1578: }
1579: return $answer;
1580: }
1581:
1.13 www 1582: # -------------------------------------------------------------- Talk to lonsql
1583:
1.12 harris41 1584: sub sqlreply {
1585: my ($cmd)=@_;
1586: my $answer=subsqlreply($cmd);
1587: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
1588: return $answer;
1589: }
1590:
1591: sub subsqlreply {
1592: my ($cmd)=@_;
1593: my $unixsock="mysqlsock";
1594: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
1595: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
1596: Type => SOCK_STREAM,
1597: Timeout => 10)
1598: or return "con_lost";
1599: print $sclient "$cmd\n";
1600: my $answer=<$sclient>;
1601: chomp($answer);
1602: if (!$answer) { $answer="con_lost"; }
1603: return $answer;
1604: }
1605:
1.1 albertel 1606: # -------------------------------------------- Return path to profile directory
1.11 www 1607:
1.1 albertel 1608: sub propath {
1609: my ($udom,$uname)=@_;
1610: $udom=~s/\W//g;
1611: $uname=~s/\W//g;
1.16 www 1612: my $subdir=$uname.'__';
1.1 albertel 1613: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
1614: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
1615: return $proname;
1616: }
1617:
1618: # --------------------------------------- Is this the home server of an author?
1.11 www 1619:
1.1 albertel 1620: sub ishome {
1621: my $author=shift;
1622: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
1623: my ($udom,$uname)=split(/\//,$author);
1624: my $proname=propath($udom,$uname);
1625: if (-e $proname) {
1626: return 'owner';
1627: } else {
1628: return 'not_owner';
1629: }
1630: }
1631:
1632: # ======================================================= Continue main program
1633: # ---------------------------------------------------- Fork once and dissociate
1634:
1.134 albertel 1635: my $fpid=fork;
1.1 albertel 1636: exit if $fpid;
1.29 harris41 1637: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 1638:
1.29 harris41 1639: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 1640:
1641: # ------------------------------------------------------- Write our PID on disk
1642:
1.134 albertel 1643: my $execdir=$perlvar{'lonDaemons'};
1.1 albertel 1644: open (PIDSAVE,">$execdir/logs/lond.pid");
1645: print PIDSAVE "$$\n";
1646: close(PIDSAVE);
1.190 albertel 1647: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
1.57 www 1648: &status('Starting');
1.1 albertel 1649:
1.106 foxr 1650:
1.1 albertel 1651:
1652: # ----------------------------------------------------- Install signal handlers
1653:
1.57 www 1654:
1.1 albertel 1655: $SIG{CHLD} = \&REAPER;
1656: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
1657: $SIG{HUP} = \&HUPSMAN;
1.57 www 1658: $SIG{USR1} = \&checkchildren;
1.144 foxr 1659: $SIG{USR2} = \&UpdateHosts;
1.106 foxr 1660:
1.148 foxr 1661: # Read the host hashes:
1662:
1663: ReadHostTable;
1.106 foxr 1664:
1665: # --------------------------------------------------------------
1666: # Accept connections. When a connection comes in, it is validated
1667: # and if good, a child process is created to process transactions
1668: # along the connection.
1669:
1.1 albertel 1670: while (1) {
1.165 albertel 1671: &status('Starting accept');
1.106 foxr 1672: $client = $server->accept() or next;
1.165 albertel 1673: &status('Accepted '.$client.' off to spawn');
1.106 foxr 1674: make_new_child($client);
1.165 albertel 1675: &status('Finished spawning');
1.1 albertel 1676: }
1677:
1678: sub make_new_child {
1679: my $pid;
1.207 foxr 1680: # my $cipher; # Now global
1.1 albertel 1681: my $sigset;
1.106 foxr 1682:
1683: $client = shift;
1.165 albertel 1684: &status('Starting new child '.$client);
1.161 foxr 1685: &logthis('<font color="green"> Attempting to start child ('.$client.
1686: ")</font>");
1.1 albertel 1687: # block signal for fork
1688: $sigset = POSIX::SigSet->new(SIGINT);
1689: sigprocmask(SIG_BLOCK, $sigset)
1.29 harris41 1690: or die "Can't block SIGINT for fork: $!\n";
1.134 albertel 1691:
1.29 harris41 1692: die "fork: $!" unless defined ($pid = fork);
1.148 foxr 1693:
1694: $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
1695: # connection liveness.
1696:
1697: #
1698: # Figure out who we're talking to so we can record the peer in
1699: # the pid hash.
1700: #
1701: my $caller = getpeername($client);
1.180 albertel 1702: my ($port,$iaddr);
1703: if (defined($caller) && length($caller) > 0) {
1704: ($port,$iaddr)=unpack_sockaddr_in($caller);
1705: } else {
1706: &logthis("Unable to determine who caller was, getpeername returned nothing");
1707: }
1708: if (defined($iaddr)) {
1.200 matthew 1709: $clientip = inet_ntoa($iaddr);
1710: Debug("Connected with $clientip");
1711: $clientdns = gethostbyaddr($iaddr, AF_INET);
1712: Debug("Connected with $clientdns by name");
1.180 albertel 1713: } else {
1.200 matthew 1714: &logthis("Unable to determine clientip");
1.180 albertel 1715: $clientip='Unavailable';
1716: }
1.1 albertel 1717:
1718: if ($pid) {
1719: # Parent records the child's birth and returns.
1720: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 1721: or die "Can't unblock SIGINT for fork: $!\n";
1.148 foxr 1722: $children{$pid} = $clientip;
1.57 www 1723: &status('Started child '.$pid);
1.1 albertel 1724: return;
1725: } else {
1726: # Child can *not* return from this subroutine.
1727: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
1.126 albertel 1728: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
1729: #don't get intercepted
1.57 www 1730: $SIG{USR1}= \&logstatus;
1.63 www 1731: $SIG{ALRM}= \&timeout;
1.57 www 1732: $lastlog='Forked ';
1733: $status='Forked';
1734:
1.1 albertel 1735: # unblock signals
1736: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 1737: or die "Can't unblock SIGINT for fork: $!\n";
1.13 www 1738:
1.207 foxr 1739: # my $tmpsnum=0; # Now global
1.178 foxr 1740: #---------------------------------------------------- kerberos 5 initialization
1.91 albertel 1741: &Authen::Krb5::init_context();
1742: &Authen::Krb5::init_ets();
1743:
1.161 foxr 1744: &status('Accepted connection');
1.1 albertel 1745: # =============================================================================
1746: # do something with the connection
1747: # -----------------------------------------------------------------------------
1.200 matthew 1748: # see if we know client and 'check' for spoof IP by ineffective challenge
1.148 foxr 1749:
1.161 foxr 1750: ReadManagerTable; # May also be a manager!!
1751:
1752: my $clientrec=($hostid{$clientip} ne undef);
1753: my $ismanager=($managers{$clientip} ne undef);
1754: $clientname = "[unknonwn]";
1755: if($clientrec) { # Establish client type.
1756: $ConnectionType = "client";
1757: $clientname = $hostid{$clientip};
1758: if($ismanager) {
1759: $ConnectionType = "both";
1760: }
1761: } else {
1762: $ConnectionType = "manager";
1763: $clientname = $managers{$clientip};
1764: }
1765: my $clientok;
1.200 matthew 1766:
1.161 foxr 1767: if ($clientrec || $ismanager) {
1768: &status("Waiting for init from $clientip $clientname");
1769: &logthis('<font color="yellow">INFO: Connection, '.
1770: $clientip.
1771: " ($clientname) connection type = $ConnectionType </font>" );
1772: &status("Connecting $clientip ($clientname))");
1773: my $remotereq=<$client>;
1.200 matthew 1774: chomp($remotereq);
1775: Debug("Got init: $remotereq");
1776: my $inikeyword = split(/:/, $remotereq);
1.161 foxr 1777: if ($remotereq =~ /^init/) {
1778: &sethost("sethost:$perlvar{'lonHostID'}");
1.200 matthew 1779: #
1780: # If the remote is attempting a local init... give that a try:
1781: #
1782: my ($i, $inittype) = split(/:/, $remotereq);
1783:
1784: # If the connection type is ssl, but I didn't get my
1785: # certificate files yet, then I'll drop back to
1786: # insecure (if allowed).
1787:
1788: if($inittype eq "ssl") {
1789: my ($ca, $cert) = lonssl::CertificateFile;
1790: my $kfile = lonssl::KeyFile;
1791: if((!$ca) ||
1792: (!$cert) ||
1793: (!$kfile)) {
1794: $inittype = ""; # This forces insecure attempt.
1795: &logthis("<font color=\"blue\"> Certificates not "
1796: ."installed -- trying insecure auth</font>");
1797: }
1798: else { # SSL certificates are in place so
1799: } # Leave the inittype alone.
1800: }
1801:
1802: if($inittype eq "local") {
1803: my $key = LocalConnection($client, $remotereq);
1804: if($key) {
1805: Debug("Got local key $key");
1806: $clientok = 1;
1807: my $cipherkey = pack("H32", $key);
1808: $cipher = new IDEA($cipherkey);
1809: print $client "ok:local\n";
1810: &logthis('<font color="green"'
1811: . "Successful local authentication </font>");
1812: $keymode = "local"
1813: } else {
1814: Debug("Failed to get local key");
1815: $clientok = 0;
1816: shutdown($client, 3);
1817: close $client;
1818: }
1819: } elsif ($inittype eq "ssl") {
1820: my $key = SSLConnection($client);
1821: if ($key) {
1822: $clientok = 1;
1823: my $cipherkey = pack("H32", $key);
1824: $cipher = new IDEA($cipherkey);
1825: &logthis('<font color="green">'
1826: ."Successfull ssl authentication with $clientname </font>");
1827: $keymode = "ssl";
1828:
1829: } else {
1830: $clientok = 0;
1831: close $client;
1832: }
1833:
1.161 foxr 1834: } else {
1.200 matthew 1835: my $ok = InsecureConnection($client);
1836: if($ok) {
1837: $clientok = 1;
1838: &logthis('<font color="green">'
1839: ."Successful insecure authentication with $clientname </font>");
1840: print $client "ok\n";
1841: $keymode = "insecure";
1842: } else {
1843: &logthis('<font color="yellow">'
1844: ."Attempted insecure connection disallowed </font>");
1845: close $client;
1846: $clientok = 0;
1847:
1848: }
1.161 foxr 1849: }
1.2 www 1850: } else {
1.161 foxr 1851: &logthis(
1.190 albertel 1852: "<font color='blue'>WARNING: "
1.161 foxr 1853: ."$clientip failed to initialize: >$remotereq< </font>");
1854: &status('No init '.$clientip);
1855: }
1.200 matthew 1856:
1.161 foxr 1857: } else {
1858: &logthis(
1.190 albertel 1859: "<font color='blue'>WARNING: Unknown client $clientip</font>");
1.161 foxr 1860: &status('Hung up on '.$clientip);
1861: }
1.200 matthew 1862:
1.161 foxr 1863: if ($clientok) {
1.1 albertel 1864: # ---------------- New known client connecting, could mean machine online again
1.161 foxr 1865:
1866: foreach my $id (keys(%hostip)) {
1867: if ($hostip{$id} ne $clientip ||
1868: $hostip{$currenthostid} eq $clientip) {
1869: # no need to try to do recon's to myself
1870: next;
1.115 albertel 1871: }
1.161 foxr 1872: &reconlonc("$perlvar{'lonSockDir'}/$id");
1873: }
1.190 albertel 1874: &logthis("<font color='green'>Established connection: $clientname</font>");
1.161 foxr 1875: &status('Will listen to '.$clientname);
1.178 foxr 1876: # ------------------------------------------------------------ Process requests
1877: while (my $userinput=<$client>) {
1878: chomp($userinput);
1879: Debug("Request = $userinput\n");
1880: &status('Processing '.$clientname.': '.$userinput);
1881: my $wasenc=0;
1882: alarm(120);
1883: # ------------------------------------------------------------ See if encrypted
1884: if ($userinput =~ /^enc/) {
1885: if ($cipher) {
1886: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
1887: $userinput='';
1888: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
1889: $userinput.=
1890: $cipher->decrypt(
1891: pack("H16",substr($encinput,$encidx,16))
1892: );
1893: }
1894: $userinput=substr($userinput,0,$cmdlength);
1895: $wasenc=1;
1896: }
1897: }
1898:
1899: # ------------------------------------------------------------- Normal commands
1900: # ------------------------------------------------------------------------ ping
1901: if ($userinput =~ /^ping/) { # client only
1902: if(isClient) {
1903: print $client "$currenthostid\n";
1904: } else {
1905: Reply($client, "refused\n", $userinput);
1906: }
1907: # ------------------------------------------------------------------------ pong
1908: }elsif ($userinput =~ /^pong/) { # client only
1909: if(isClient) {
1910: my $reply=&reply("ping",$clientname);
1911: print $client "$currenthostid:$reply\n";
1912: } else {
1913: Reply($client, "refused\n", $userinput);
1914: }
1915: # ------------------------------------------------------------------------ ekey
1916: } elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs
1917: my $buildkey=time.$$.int(rand 100000);
1918: $buildkey=~tr/1-6/A-F/;
1919: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
1920: my $key=$currenthostid.$clientname;
1921: $key=~tr/a-z/A-Z/;
1922: $key=~tr/G-P/0-9/;
1923: $key=~tr/Q-Z/0-9/;
1924: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
1925: $key=substr($key,0,32);
1926: my $cipherkey=pack("H32",$key);
1927: $cipher=new IDEA $cipherkey;
1928: print $client "$buildkey\n";
1929: # ------------------------------------------------------------------------ load
1930: } elsif ($userinput =~ /^load/) { # client only
1931: if (isClient) {
1932: my $loadavg;
1933: {
1934: my $loadfile=IO::File->new('/proc/loadavg');
1935: $loadavg=<$loadfile>;
1936: }
1937: $loadavg =~ s/\s.*//g;
1938: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
1939: print $client "$loadpercent\n";
1940: } else {
1941: Reply($client, "refused\n", $userinput);
1942:
1943: }
1944: # -------------------------------------------------------------------- userload
1945: } elsif ($userinput =~ /^userload/) { # client only
1946: if(isClient) {
1947: my $userloadpercent=&userload();
1948: print $client "$userloadpercent\n";
1949: } else {
1950: Reply($client, "refused\n", $userinput);
1951:
1952: }
1953: #
1954: # Transactions requiring encryption:
1955: #
1956: # ----------------------------------------------------------------- currentauth
1957: } elsif ($userinput =~ /^currentauth/) {
1958: if (($wasenc==1) && isClient) { # Encoded & client only.
1959: my ($cmd,$udom,$uname)=split(/:/,$userinput);
1960: my $result = GetAuthType($udom, $uname);
1961: if($result eq "nouser") {
1962: print $client "unknown_user\n";
1963: }
1964: else {
1965: print $client "$result\n"
1966: }
1967: } else {
1968: Reply($client, "refused\n", $userinput);
1969:
1970: }
1971: #--------------------------------------------------------------------- pushfile
1972: } elsif($userinput =~ /^pushfile/) { # encoded & manager.
1973: if(($wasenc == 1) && isManager) {
1974: my $cert = GetCertificate($userinput);
1975: if(ValidManager($cert)) {
1976: my $reply = PushFile($userinput);
1977: print $client "$reply\n";
1978: } else {
1979: print $client "refused\n";
1980: }
1981: } else {
1982: Reply($client, "refused\n", $userinput);
1983:
1984: }
1985: #--------------------------------------------------------------------- reinit
1986: } elsif($userinput =~ /^reinit/) { # Encoded and manager
1987: if (($wasenc == 1) && isManager) {
1988: my $cert = GetCertificate($userinput);
1989: if(ValidManager($cert)) {
1990: chomp($userinput);
1991: my $reply = ReinitProcess($userinput);
1992: print $client "$reply\n";
1993: } else {
1994: print $client "refused\n";
1995: }
1996: } else {
1997: Reply($client, "refused\n", $userinput);
1998: }
1999: #------------------------------------------------------------------------- edit
2000: } elsif ($userinput =~ /^edit/) { # encoded and manager:
2001: if(($wasenc ==1) && (isManager)) {
2002: my $cert = GetCertificate($userinput);
2003: if(ValidManager($cert)) {
2004: my($command, $filetype, $script) = split(/:/, $userinput);
2005: if (($filetype eq "hosts") || ($filetype eq "domain")) {
2006: if($script ne "") {
2007: Reply($client, EditFile($userinput));
2008: } else {
2009: Reply($client,"refused\n",$userinput);
2010: }
2011: } else {
2012: Reply($client,"refused\n",$userinput);
2013: }
2014: } else {
2015: Reply($client,"refused\n",$userinput);
2016: }
2017: } else {
2018: Reply($client,"refused\n",$userinput);
2019: }
2020: # ------------------------------------------------------------------------ auth
2021: } elsif ($userinput =~ /^auth/) { # Encoded and client only.
2022: if (($wasenc==1) && isClient) {
2023: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
2024: chomp($upass);
2025: $upass=unescape($upass);
2026: my $proname=propath($udom,$uname);
2027: my $passfilename="$proname/passwd";
2028: if (-e $passfilename) {
2029: my $pf = IO::File->new($passfilename);
2030: my $realpasswd=<$pf>;
2031: chomp($realpasswd);
2032: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
2033: my $pwdcorrect=0;
2034: if ($howpwd eq 'internal') {
2035: &Debug("Internal auth");
2036: $pwdcorrect=
2037: (crypt($upass,$contentpwd) eq $contentpwd);
2038: } elsif ($howpwd eq 'unix') {
2039: &Debug("Unix auth");
2040: if((getpwnam($uname))[1] eq "") { #no such user!
2041: $pwdcorrect = 0;
2042: } else {
2043: $contentpwd=(getpwnam($uname))[1];
2044: my $pwauth_path="/usr/local/sbin/pwauth";
2045: unless ($contentpwd eq 'x') {
2046: $pwdcorrect=
2047: (crypt($upass,$contentpwd) eq
2048: $contentpwd);
2049: }
2050:
2051: elsif (-e $pwauth_path) {
2052: open PWAUTH, "|$pwauth_path" or
2053: die "Cannot invoke authentication";
2054: print PWAUTH "$uname\n$upass\n";
2055: close PWAUTH;
2056: $pwdcorrect=!$?;
2057: }
2058: }
2059: } elsif ($howpwd eq 'krb4') {
2060: my $null=pack("C",0);
2061: unless ($upass=~/$null/) {
2062: my $krb4_error = &Authen::Krb4::get_pw_in_tkt
2063: ($uname,"",$contentpwd,'krbtgt',
2064: $contentpwd,1,$upass);
2065: if (!$krb4_error) {
2066: $pwdcorrect = 1;
2067: } else {
2068: $pwdcorrect=0;
2069: # log error if it is not a bad password
2070: if ($krb4_error != 62) {
1.191 albertel 2071: &logthis('krb4:'.$uname.','.
1.178 foxr 2072: &Authen::Krb4::get_err_txt($Authen::Krb4::error));
2073: }
2074: }
2075: }
2076: } elsif ($howpwd eq 'krb5') {
2077: my $null=pack("C",0);
2078: unless ($upass=~/$null/) {
2079: my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
2080: my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
2081: my $krbserver=&Authen::Krb5::parse_name($krbservice);
2082: my $credentials=&Authen::Krb5::cc_default();
2083: $credentials->initialize($krbclient);
2084: my $krbreturn =
2085: &Authen::Krb5::get_in_tkt_with_password(
2086: $krbclient,$krbserver,$upass,$credentials);
2087: # unless ($krbreturn) {
2088: # &logthis("Krb5 Error: ".
2089: # &Authen::Krb5::error());
2090: # }
2091: $pwdcorrect = ($krbreturn == 1);
2092: } else { $pwdcorrect=0; }
2093: } elsif ($howpwd eq 'localauth') {
2094: $pwdcorrect=&localauth::localauth($uname,$upass,
2095: $contentpwd);
2096: }
2097: if ($pwdcorrect) {
2098: print $client "authorized\n";
2099: } else {
2100: print $client "non_authorized\n";
2101: }
2102: } else {
2103: print $client "unknown_user\n";
2104: }
2105: } else {
2106: Reply($client, "refused\n", $userinput);
2107:
2108: }
2109: # ---------------------------------------------------------------------- passwd
2110: } elsif ($userinput =~ /^passwd/) { # encoded and client
2111: if (($wasenc==1) && isClient) {
2112: my
2113: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
2114: chomp($npass);
2115: $upass=&unescape($upass);
2116: $npass=&unescape($npass);
2117: &Debug("Trying to change password for $uname");
2118: my $proname=propath($udom,$uname);
2119: my $passfilename="$proname/passwd";
2120: if (-e $passfilename) {
2121: my $realpasswd;
2122: { my $pf = IO::File->new($passfilename);
2123: $realpasswd=<$pf>; }
2124: chomp($realpasswd);
2125: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
2126: if ($howpwd eq 'internal') {
2127: &Debug("internal auth");
2128: if (crypt($upass,$contentpwd) eq $contentpwd) {
2129: my $salt=time;
2130: $salt=substr($salt,6,2);
2131: my $ncpass=crypt($npass,$salt);
2132: {
2133: my $pf;
2134: if ($pf = IO::File->new(">$passfilename")) {
2135: print $pf "internal:$ncpass\n";
2136: &logthis("Result of password change for $uname: pwchange_success");
2137: print $client "ok\n";
2138: } else {
2139: &logthis("Unable to open $uname passwd to change password");
2140: print $client "non_authorized\n";
2141: }
2142: }
2143:
2144: } else {
2145: print $client "non_authorized\n";
2146: }
2147: } elsif ($howpwd eq 'unix') {
2148: # Unix means we have to access /etc/password
2149: # one way or another.
2150: # First: Make sure the current password is
2151: # correct
2152: &Debug("auth is unix");
2153: $contentpwd=(getpwnam($uname))[1];
2154: my $pwdcorrect = "0";
2155: my $pwauth_path="/usr/local/sbin/pwauth";
2156: unless ($contentpwd eq 'x') {
2157: $pwdcorrect=
2158: (crypt($upass,$contentpwd) eq $contentpwd);
2159: } elsif (-e $pwauth_path) {
2160: open PWAUTH, "|$pwauth_path" or
2161: die "Cannot invoke authentication";
2162: print PWAUTH "$uname\n$upass\n";
2163: close PWAUTH;
2164: &Debug("exited pwauth with $? ($uname,$upass) ");
2165: $pwdcorrect=($? == 0);
2166: }
2167: if ($pwdcorrect) {
2168: my $execdir=$perlvar{'lonDaemons'};
2169: &Debug("Opening lcpasswd pipeline");
2170: my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
2171: print $pf "$uname\n$npass\n$npass\n";
2172: close $pf;
2173: my $err = $?;
2174: my $result = ($err>0 ? 'pwchange_failure'
2175: : 'ok');
2176: &logthis("Result of password change for $uname: ".
2177: &lcpasswdstrerror($?));
2178: print $client "$result\n";
2179: } else {
2180: print $client "non_authorized\n";
2181: }
2182: } else {
2183: print $client "auth_mode_error\n";
2184: }
2185: } else {
2186: print $client "unknown_user\n";
2187: }
2188: } else {
2189: Reply($client, "refused\n", $userinput);
2190:
2191: }
2192: # -------------------------------------------------------------------- makeuser
2193: } elsif ($userinput =~ /^makeuser/) { # encoded and client.
2194: &Debug("Make user received");
2195: my $oldumask=umask(0077);
2196: if (($wasenc==1) && isClient) {
2197: my
2198: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
2199: &Debug("cmd =".$cmd." $udom =".$udom.
2200: " uname=".$uname);
2201: chomp($npass);
2202: $npass=&unescape($npass);
2203: my $proname=propath($udom,$uname);
2204: my $passfilename="$proname/passwd";
2205: &Debug("Password file created will be:".
2206: $passfilename);
2207: if (-e $passfilename) {
2208: print $client "already_exists\n";
2209: } elsif ($udom ne $currentdomainid) {
2210: print $client "not_right_domain\n";
2211: } else {
2212: my @fpparts=split(/\//,$proname);
2213: my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
2214: my $fperror='';
2215: for (my $i=3;$i<=$#fpparts;$i++) {
2216: $fpnow.='/'.$fpparts[$i];
2217: unless (-e $fpnow) {
2218: unless (mkdir($fpnow,0777)) {
2219: $fperror="error: ".($!+0)
2220: ." mkdir failed while attempting "
2221: ."makeuser";
2222: }
2223: }
2224: }
2225: unless ($fperror) {
2226: my $result=&make_passwd_file($uname, $umode,$npass,
2227: $passfilename);
2228: print $client $result;
2229: } else {
2230: print $client "$fperror\n";
2231: }
2232: }
2233: } else {
2234: Reply($client, "refused\n", $userinput);
2235:
2236: }
2237: umask($oldumask);
2238: # -------------------------------------------------------------- changeuserauth
2239: } elsif ($userinput =~ /^changeuserauth/) { # encoded & client
2240: &Debug("Changing authorization");
2241: if (($wasenc==1) && isClient) {
2242: my
2243: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
2244: chomp($npass);
2245: &Debug("cmd = ".$cmd." domain= ".$udom.
2246: "uname =".$uname." umode= ".$umode);
2247: $npass=&unescape($npass);
2248: my $proname=&propath($udom,$uname);
2249: my $passfilename="$proname/passwd";
2250: if ($udom ne $currentdomainid) {
2251: print $client "not_right_domain\n";
2252: } else {
2253: my $result=&make_passwd_file($uname, $umode,$npass,
2254: $passfilename);
2255: print $client $result;
2256: }
2257: } else {
2258: Reply($client, "refused\n", $userinput);
2259:
2260: }
2261: # ------------------------------------------------------------------------ home
2262: } elsif ($userinput =~ /^home/) { # client clear or encoded
2263: if(isClient) {
2264: my ($cmd,$udom,$uname)=split(/:/,$userinput);
2265: chomp($uname);
2266: my $proname=propath($udom,$uname);
2267: if (-e $proname) {
2268: print $client "found\n";
2269: } else {
2270: print $client "not_found\n";
2271: }
2272: } else {
2273: Reply($client, "refused\n", $userinput);
2274:
2275: }
2276: # ---------------------------------------------------------------------- update
2277: } elsif ($userinput =~ /^update/) { # client clear or encoded.
2278: if(isClient) {
2279: my ($cmd,$fname)=split(/:/,$userinput);
2280: my $ownership=ishome($fname);
2281: if ($ownership eq 'not_owner') {
2282: if (-e $fname) {
2283: my ($dev,$ino,$mode,$nlink,
2284: $uid,$gid,$rdev,$size,
2285: $atime,$mtime,$ctime,
2286: $blksize,$blocks)=stat($fname);
2287: my $now=time;
2288: my $since=$now-$atime;
2289: if ($since>$perlvar{'lonExpire'}) {
2290: my $reply=
2291: &reply("unsub:$fname","$clientname");
2292: unlink("$fname");
2293: } else {
2294: my $transname="$fname.in.transfer";
2295: my $remoteurl=
2296: &reply("sub:$fname","$clientname");
2297: my $response;
2298: {
2299: my $ua=new LWP::UserAgent;
2300: my $request=new HTTP::Request('GET',"$remoteurl");
2301: $response=$ua->request($request,$transname);
2302: }
2303: if ($response->is_error()) {
2304: unlink($transname);
2305: my $message=$response->status_line;
2306: &logthis(
2307: "LWP GET: $message for $fname ($remoteurl)");
2308: } else {
2309: if ($remoteurl!~/\.meta$/) {
2310: my $ua=new LWP::UserAgent;
2311: my $mrequest=
2312: new HTTP::Request('GET',$remoteurl.'.meta');
2313: my $mresponse=
2314: $ua->request($mrequest,$fname.'.meta');
2315: if ($mresponse->is_error()) {
2316: unlink($fname.'.meta');
2317: }
2318: }
2319: rename($transname,$fname);
2320: }
2321: }
2322: print $client "ok\n";
2323: } else {
2324: print $client "not_found\n";
2325: }
2326: } else {
2327: print $client "rejected\n";
2328: }
2329: } else {
2330: Reply($client, "refused\n", $userinput);
2331:
2332: }
2333: # -------------------------------------- fetch a user file from a remote server
2334: } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
2335: if(isClient) {
1.184 raeburn 2336: my ($cmd,$fname)=split(/:/,$userinput);
1.185 albertel 2337: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
1.178 foxr 2338: my $udir=propath($udom,$uname).'/userfiles';
2339: unless (-e $udir) { mkdir($udir,0770); }
2340: if (-e $udir) {
1.184 raeburn 2341: $ufile=~s/^[\.\~]+//;
2342: my $path = $udir;
1.185 albertel 2343: if ($ufile =~m|(.+)/([^/]+)$|) {
2344: my @parts=split('/',$1);
1.184 raeburn 2345: foreach my $part (@parts) {
2346: $path .= '/'.$part;
2347: if ((-e $path)!=1) {
2348: mkdir($path,0770);
1.182 raeburn 2349: }
2350: }
2351: }
1.184 raeburn 2352: my $destname=$udir.'/'.$ufile;
2353: my $transname=$udir.'/'.$ufile.'.in.transit';
2354: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
1.178 foxr 2355: my $response;
2356: {
2357: my $ua=new LWP::UserAgent;
2358: my $request=new HTTP::Request('GET',"$remoteurl");
2359: $response=$ua->request($request,$transname);
2360: }
2361: if ($response->is_error()) {
2362: unlink($transname);
2363: my $message=$response->status_line;
1.184 raeburn 2364: &logthis("LWP GET: $message for $fname ($remoteurl)");
1.178 foxr 2365: print $client "failed\n";
2366: } else {
2367: if (!rename($transname,$destname)) {
2368: &logthis("Unable to move $transname to $destname");
2369: unlink($transname);
2370: print $client "failed\n";
2371: } else {
2372: print $client "ok\n";
2373: }
2374: }
2375: } else {
2376: print $client "not_home\n";
1.187 albertel 2377: }
2378: } else {
2379: Reply($client, "refused\n", $userinput);
2380: }
2381: # --------------------------------------------------------- remove a user file
2382: } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
2383: if(isClient) {
2384: my ($cmd,$fname)=split(/:/,$userinput);
2385: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
2386: &logthis("$udom - $uname - $ufile");
2387: if ($ufile =~m|/\.\./|) {
2388: # any files paths with /../ in them refuse
2389: # to deal with
2390: print $client "refused\n";
2391: } else {
2392: my $udir=propath($udom,$uname);
2393: if (-e $udir) {
2394: my $file=$udir.'/userfiles/'.$ufile;
2395: if (-e $file) {
2396: unlink($file);
2397: if (-e $file) {
2398: print $client "failed\n";
2399: } else {
2400: print $client "ok\n";
2401: }
2402: } else {
2403: print $client "not_found\n";
2404: }
2405: } else {
2406: print $client "not_home\n";
2407: }
1.178 foxr 2408: }
2409: } else {
2410: Reply($client, "refused\n", $userinput);
2411: }
2412: # ------------------------------------------ authenticate access to a user file
2413: } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
2414: if(isClient) {
2415: my ($cmd,$fname,$session)=split(/:/,$userinput);
2416: chomp($session);
2417: my $reply='non_auth';
2418: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
2419: $session.'.id')) {
2420: while (my $line=<ENVIN>) {
1.185 albertel 2421: if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
1.178 foxr 2422: }
2423: close(ENVIN);
2424: print $client $reply."\n";
2425: } else {
2426: print $client "invalid_token\n";
2427: }
2428: } else {
2429: Reply($client, "refused\n", $userinput);
2430:
2431: }
2432: # ----------------------------------------------------------------- unsubscribe
2433: } elsif ($userinput =~ /^unsub/) {
2434: if(isClient) {
2435: my ($cmd,$fname)=split(/:/,$userinput);
2436: if (-e $fname) {
1.188 foxr 2437: print $client &unsub($fname,$clientip);
1.178 foxr 2438: } else {
2439: print $client "not_found\n";
2440: }
2441: } else {
2442: Reply($client, "refused\n", $userinput);
2443:
2444: }
2445: # ------------------------------------------------------------------- subscribe
2446: } elsif ($userinput =~ /^sub/) {
2447: if(isClient) {
2448: print $client &subscribe($userinput,$clientip);
2449: } else {
2450: Reply($client, "refused\n", $userinput);
2451:
2452: }
2453: # ------------------------------------------------------------- current version
2454: } elsif ($userinput =~ /^currentversion/) {
2455: if(isClient) {
2456: my ($cmd,$fname)=split(/:/,$userinput);
2457: print $client ¤tversion($fname)."\n";
2458: } else {
2459: Reply($client, "refused\n", $userinput);
2460:
2461: }
2462: # ------------------------------------------------------------------------- log
2463: } elsif ($userinput =~ /^log/) {
2464: if(isClient) {
2465: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
2466: chomp($what);
2467: my $proname=propath($udom,$uname);
2468: my $now=time;
2469: {
2470: my $hfh;
2471: if ($hfh=IO::File->new(">>$proname/activity.log")) {
2472: print $hfh "$now:$clientname:$what\n";
2473: print $client "ok\n";
2474: } else {
2475: print $client "error: ".($!+0)
2476: ." IO::File->new Failed "
2477: ."while attempting log\n";
2478: }
2479: }
2480: } else {
2481: Reply($client, "refused\n", $userinput);
2482:
2483: }
2484: # ------------------------------------------------------------------------- put
2485: } elsif ($userinput =~ /^put/) {
2486: if(isClient) {
1.208 albertel 2487: my ($cmd,$udom,$uname,$namespace,$what)
2488: =split(/:/,$userinput,5);
1.178 foxr 2489: $namespace=~s/\//\_/g;
2490: $namespace=~s/\W//g;
2491: if ($namespace ne 'roles') {
2492: chomp($what);
2493: my $proname=propath($udom,$uname);
2494: my $now=time;
2495: my @pairs=split(/\&/,$what);
2496: my %hash;
2497: if (tie(%hash,'GDBM_File',
2498: "$proname/$namespace.db",
2499: &GDBM_WRCREAT(),0640)) {
1.209 ! albertel 2500: unless ($namespace=~/^nohist\_/) {
! 2501: my $hfh;
! 2502: if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
! 2503: }
! 2504:
1.178 foxr 2505: foreach my $pair (@pairs) {
2506: my ($key,$value)=split(/=/,$pair);
2507: $hash{$key}=$value;
2508: }
2509: if (untie(%hash)) {
2510: print $client "ok\n";
2511: } else {
2512: print $client "error: ".($!+0)
2513: ." untie(GDBM) failed ".
2514: "while attempting put\n";
2515: }
2516: } else {
2517: print $client "error: ".($!)
2518: ." tie(GDBM) Failed ".
2519: "while attempting put\n";
2520: }
2521: } else {
2522: print $client "refused\n";
2523: }
2524: } else {
2525: Reply($client, "refused\n", $userinput);
2526:
2527: }
2528: # ------------------------------------------------------------------- inc
2529: } elsif ($userinput =~ /^inc:/) {
2530: if(isClient) {
2531: my ($cmd,$udom,$uname,$namespace,$what)
2532: =split(/:/,$userinput);
2533: $namespace=~s/\//\_/g;
2534: $namespace=~s/\W//g;
2535: if ($namespace ne 'roles') {
2536: chomp($what);
2537: my $proname=propath($udom,$uname);
2538: my $now=time;
2539: my @pairs=split(/\&/,$what);
2540: my %hash;
2541: if (tie(%hash,'GDBM_File',
2542: "$proname/$namespace.db",
2543: &GDBM_WRCREAT(),0640)) {
1.209 ! albertel 2544: unless ($namespace=~/^nohist\_/) {
! 2545: my $hfh;
! 2546: if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
! 2547: }
1.178 foxr 2548: foreach my $pair (@pairs) {
2549: my ($key,$value)=split(/=/,$pair);
2550: # We could check that we have a number...
2551: if (! defined($value) || $value eq '') {
2552: $value = 1;
2553: }
2554: $hash{$key}+=$value;
2555: }
2556: if (untie(%hash)) {
2557: print $client "ok\n";
2558: } else {
2559: print $client "error: ".($!+0)
2560: ." untie(GDBM) failed ".
1.181 albertel 2561: "while attempting inc\n";
1.178 foxr 2562: }
2563: } else {
2564: print $client "error: ".($!)
2565: ." tie(GDBM) Failed ".
1.181 albertel 2566: "while attempting inc\n";
1.178 foxr 2567: }
2568: } else {
2569: print $client "refused\n";
2570: }
2571: } else {
2572: Reply($client, "refused\n", $userinput);
2573:
2574: }
2575: # -------------------------------------------------------------------- rolesput
2576: } elsif ($userinput =~ /^rolesput/) {
2577: if(isClient) {
2578: &Debug("rolesput");
2579: if ($wasenc==1) {
2580: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
2581: =split(/:/,$userinput);
2582: &Debug("cmd = ".$cmd." exedom= ".$exedom.
2583: "user = ".$exeuser." udom=".$udom.
2584: "what = ".$what);
2585: my $namespace='roles';
2586: chomp($what);
2587: my $proname=propath($udom,$uname);
2588: my $now=time;
2589: my @pairs=split(/\&/,$what);
2590: my %hash;
2591: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1.209 ! albertel 2592: {
! 2593: my $hfh;
! 2594: if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
! 2595: print $hfh "P:$now:$exedom:$exeuser:$what\n";
! 2596: }
! 2597: }
! 2598:
1.178 foxr 2599: foreach my $pair (@pairs) {
2600: my ($key,$value)=split(/=/,$pair);
2601: &ManagePermissions($key, $udom, $uname,
2602: &GetAuthType( $udom,
2603: $uname));
2604: $hash{$key}=$value;
2605: }
2606: if (untie(%hash)) {
2607: print $client "ok\n";
2608: } else {
2609: print $client "error: ".($!+0)
2610: ." untie(GDBM) Failed ".
2611: "while attempting rolesput\n";
2612: }
2613: } else {
2614: print $client "error: ".($!+0)
2615: ." tie(GDBM) Failed ".
2616: "while attempting rolesput\n";
2617: }
2618: } else {
2619: print $client "refused\n";
2620: }
2621: } else {
2622: Reply($client, "refused\n", $userinput);
2623:
2624: }
2625: # -------------------------------------------------------------------- rolesdel
2626: } elsif ($userinput =~ /^rolesdel/) {
2627: if(isClient) {
2628: &Debug("rolesdel");
2629: if ($wasenc==1) {
2630: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
2631: =split(/:/,$userinput);
2632: &Debug("cmd = ".$cmd." exedom= ".$exedom.
2633: "user = ".$exeuser." udom=".$udom.
2634: "what = ".$what);
2635: my $namespace='roles';
2636: chomp($what);
2637: my $proname=propath($udom,$uname);
2638: my $now=time;
2639: my @rolekeys=split(/\&/,$what);
2640: my %hash;
2641: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1.209 ! albertel 2642: {
! 2643: my $hfh;
! 2644: if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
! 2645: print $hfh "D:$now:$exedom:$exeuser:$what\n";
! 2646: }
! 2647: }
1.178 foxr 2648: foreach my $key (@rolekeys) {
2649: delete $hash{$key};
2650: }
2651: if (untie(%hash)) {
2652: print $client "ok\n";
2653: } else {
2654: print $client "error: ".($!+0)
2655: ." untie(GDBM) Failed ".
2656: "while attempting rolesdel\n";
2657: }
2658: } else {
2659: print $client "error: ".($!+0)
2660: ." tie(GDBM) Failed ".
2661: "while attempting rolesdel\n";
2662: }
2663: } else {
2664: print $client "refused\n";
2665: }
2666: } else {
2667: Reply($client, "refused\n", $userinput);
2668:
2669: }
2670: # ------------------------------------------------------------------------- get
2671: } elsif ($userinput =~ /^get/) {
2672: if(isClient) {
2673: my ($cmd,$udom,$uname,$namespace,$what)
2674: =split(/:/,$userinput);
2675: $namespace=~s/\//\_/g;
2676: $namespace=~s/\W//g;
2677: chomp($what);
2678: my @queries=split(/\&/,$what);
2679: my $proname=propath($udom,$uname);
2680: my $qresult='';
2681: my %hash;
2682: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2683: for (my $i=0;$i<=$#queries;$i++) {
2684: $qresult.="$hash{$queries[$i]}&";
2685: }
2686: if (untie(%hash)) {
2687: $qresult=~s/\&$//;
2688: print $client "$qresult\n";
2689: } else {
2690: print $client "error: ".($!+0)
2691: ." untie(GDBM) Failed ".
2692: "while attempting get\n";
2693: }
2694: } else {
2695: if ($!+0 == 2) {
2696: print $client "error:No such file or ".
2697: "GDBM reported bad block error\n";
2698: } else {
2699: print $client "error: ".($!+0)
2700: ." tie(GDBM) Failed ".
2701: "while attempting get\n";
2702: }
2703: }
2704: } else {
2705: Reply($client, "refused\n", $userinput);
2706:
2707: }
2708: # ------------------------------------------------------------------------ eget
2709: } elsif ($userinput =~ /^eget/) {
2710: if (isClient) {
2711: my ($cmd,$udom,$uname,$namespace,$what)
2712: =split(/:/,$userinput);
2713: $namespace=~s/\//\_/g;
2714: $namespace=~s/\W//g;
2715: chomp($what);
2716: my @queries=split(/\&/,$what);
2717: my $proname=propath($udom,$uname);
2718: my $qresult='';
2719: my %hash;
2720: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2721: for (my $i=0;$i<=$#queries;$i++) {
2722: $qresult.="$hash{$queries[$i]}&";
2723: }
2724: if (untie(%hash)) {
2725: $qresult=~s/\&$//;
2726: if ($cipher) {
2727: my $cmdlength=length($qresult);
2728: $qresult.=" ";
2729: my $encqresult='';
2730: for
2731: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
2732: $encqresult.=
2733: unpack("H16",
2734: $cipher->encrypt(substr($qresult,$encidx,8)));
2735: }
2736: print $client "enc:$cmdlength:$encqresult\n";
2737: } else {
2738: print $client "error:no_key\n";
2739: }
2740: } else {
2741: print $client "error: ".($!+0)
2742: ." untie(GDBM) Failed ".
2743: "while attempting eget\n";
2744: }
2745: } else {
2746: print $client "error: ".($!+0)
2747: ." tie(GDBM) Failed ".
2748: "while attempting eget\n";
2749: }
2750: } else {
2751: Reply($client, "refused\n", $userinput);
2752:
2753: }
2754: # ------------------------------------------------------------------------- del
2755: } elsif ($userinput =~ /^del/) {
2756: if(isClient) {
2757: my ($cmd,$udom,$uname,$namespace,$what)
2758: =split(/:/,$userinput);
2759: $namespace=~s/\//\_/g;
2760: $namespace=~s/\W//g;
2761: chomp($what);
2762: my $proname=propath($udom,$uname);
2763: my $now=time;
2764: my @keys=split(/\&/,$what);
2765: my %hash;
2766: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1.209 ! albertel 2767: unless ($namespace=~/^nohist\_/) {
! 2768: my $hfh;
! 2769: if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; }
! 2770: }
1.178 foxr 2771: foreach my $key (@keys) {
2772: delete($hash{$key});
2773: }
2774: if (untie(%hash)) {
2775: print $client "ok\n";
2776: } else {
2777: print $client "error: ".($!+0)
2778: ." untie(GDBM) Failed ".
2779: "while attempting del\n";
2780: }
2781: } else {
2782: print $client "error: ".($!+0)
2783: ." tie(GDBM) Failed ".
2784: "while attempting del\n";
2785: }
2786: } else {
2787: Reply($client, "refused\n", $userinput);
2788:
2789: }
2790: # ------------------------------------------------------------------------ keys
2791: } elsif ($userinput =~ /^keys/) {
2792: if(isClient) {
2793: my ($cmd,$udom,$uname,$namespace)
2794: =split(/:/,$userinput);
2795: $namespace=~s/\//\_/g;
2796: $namespace=~s/\W//g;
2797: my $proname=propath($udom,$uname);
2798: my $qresult='';
2799: my %hash;
2800: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2801: foreach my $key (keys %hash) {
2802: $qresult.="$key&";
2803: }
2804: if (untie(%hash)) {
2805: $qresult=~s/\&$//;
2806: print $client "$qresult\n";
2807: } else {
2808: print $client "error: ".($!+0)
2809: ." untie(GDBM) Failed ".
2810: "while attempting keys\n";
2811: }
2812: } else {
2813: print $client "error: ".($!+0)
2814: ." tie(GDBM) Failed ".
2815: "while attempting keys\n";
2816: }
2817: } else {
2818: Reply($client, "refused\n", $userinput);
2819:
2820: }
2821: # ----------------------------------------------------------------- dumpcurrent
2822: } elsif ($userinput =~ /^currentdump/) {
2823: if (isClient) {
2824: my ($cmd,$udom,$uname,$namespace)
2825: =split(/:/,$userinput);
2826: $namespace=~s/\//\_/g;
2827: $namespace=~s/\W//g;
2828: my $qresult='';
2829: my $proname=propath($udom,$uname);
2830: my %hash;
2831: if (tie(%hash,'GDBM_File',
2832: "$proname/$namespace.db",
2833: &GDBM_READER(),0640)) {
2834: # Structure of %data:
2835: # $data{$symb}->{$parameter}=$value;
2836: # $data{$symb}->{'v.'.$parameter}=$version;
2837: # since $parameter will be unescaped, we do not
2838: # have to worry about silly parameter names...
2839: my %data = ();
2840: while (my ($key,$value) = each(%hash)) {
2841: my ($v,$symb,$param) = split(/:/,$key);
2842: next if ($v eq 'version' || $symb eq 'keys');
2843: next if (exists($data{$symb}) &&
2844: exists($data{$symb}->{$param}) &&
2845: $data{$symb}->{'v.'.$param} > $v);
2846: $data{$symb}->{$param}=$value;
2847: $data{$symb}->{'v.'.$param}=$v;
2848: }
2849: if (untie(%hash)) {
2850: while (my ($symb,$param_hash) = each(%data)) {
2851: while(my ($param,$value) = each (%$param_hash)){
2852: next if ($param =~ /^v\./);
2853: $qresult.=$symb.':'.$param.'='.$value.'&';
2854: }
2855: }
2856: chop($qresult);
2857: print $client "$qresult\n";
2858: } else {
2859: print $client "error: ".($!+0)
2860: ." untie(GDBM) Failed ".
2861: "while attempting currentdump\n";
2862: }
2863: } else {
2864: print $client "error: ".($!+0)
2865: ." tie(GDBM) Failed ".
2866: "while attempting currentdump\n";
2867: }
2868: } else {
2869: Reply($client, "refused\n", $userinput);
2870: }
2871: # ------------------------------------------------------------------------ dump
2872: } elsif ($userinput =~ /^dump/) {
2873: if(isClient) {
2874: my ($cmd,$udom,$uname,$namespace,$regexp)
2875: =split(/:/,$userinput);
2876: $namespace=~s/\//\_/g;
2877: $namespace=~s/\W//g;
2878: if (defined($regexp)) {
2879: $regexp=&unescape($regexp);
2880: } else {
2881: $regexp='.';
2882: }
2883: my $qresult='';
2884: my $proname=propath($udom,$uname);
2885: my %hash;
2886: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2887: while (my ($key,$value) = each(%hash)) {
2888: if ($regexp eq '.') {
2889: $qresult.=$key.'='.$value.'&';
2890: } else {
2891: my $unescapeKey = &unescape($key);
2892: if (eval('$unescapeKey=~/$regexp/')) {
2893: $qresult.="$key=$value&";
2894: }
2895: }
2896: }
2897: if (untie(%hash)) {
2898: chop($qresult);
2899: print $client "$qresult\n";
2900: } else {
2901: print $client "error: ".($!+0)
2902: ." untie(GDBM) Failed ".
2903: "while attempting dump\n";
2904: }
2905: } else {
2906: print $client "error: ".($!+0)
2907: ." tie(GDBM) Failed ".
2908: "while attempting dump\n";
2909: }
2910: } else {
2911: Reply($client, "refused\n", $userinput);
2912:
2913: }
2914: # ----------------------------------------------------------------------- store
2915: } elsif ($userinput =~ /^store/) {
2916: if(isClient) {
2917: my ($cmd,$udom,$uname,$namespace,$rid,$what)
2918: =split(/:/,$userinput);
2919: $namespace=~s/\//\_/g;
2920: $namespace=~s/\W//g;
2921: if ($namespace ne 'roles') {
2922: chomp($what);
2923: my $proname=propath($udom,$uname);
2924: my $now=time;
2925: my @pairs=split(/\&/,$what);
2926: my %hash;
2927: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1.209 ! albertel 2928: unless ($namespace=~/^nohist\_/) {
! 2929: my $hfh;
! 2930: if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
! 2931: print $hfh "P:$now:$rid:$what\n";
! 2932: }
! 2933: }
1.178 foxr 2934: my @previouskeys=split(/&/,$hash{"keys:$rid"});
2935: my $key;
2936: $hash{"version:$rid"}++;
2937: my $version=$hash{"version:$rid"};
2938: my $allkeys='';
2939: foreach my $pair (@pairs) {
2940: my ($key,$value)=split(/=/,$pair);
2941: $allkeys.=$key.':';
2942: $hash{"$version:$rid:$key"}=$value;
2943: }
2944: $hash{"$version:$rid:timestamp"}=$now;
2945: $allkeys.='timestamp';
2946: $hash{"$version:keys:$rid"}=$allkeys;
2947: if (untie(%hash)) {
2948: print $client "ok\n";
2949: } else {
2950: print $client "error: ".($!+0)
2951: ." untie(GDBM) Failed ".
2952: "while attempting store\n";
2953: }
2954: } else {
2955: print $client "error: ".($!+0)
2956: ." tie(GDBM) Failed ".
2957: "while attempting store\n";
2958: }
2959: } else {
2960: print $client "refused\n";
2961: }
2962: } else {
2963: Reply($client, "refused\n", $userinput);
2964:
2965: }
2966: # --------------------------------------------------------------------- restore
2967: } elsif ($userinput =~ /^restore/) {
2968: if(isClient) {
2969: my ($cmd,$udom,$uname,$namespace,$rid)
2970: =split(/:/,$userinput);
2971: $namespace=~s/\//\_/g;
2972: $namespace=~s/\W//g;
2973: chomp($rid);
2974: my $proname=propath($udom,$uname);
2975: my $qresult='';
2976: my %hash;
2977: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
2978: my $version=$hash{"version:$rid"};
2979: $qresult.="version=$version&";
2980: my $scope;
2981: for ($scope=1;$scope<=$version;$scope++) {
2982: my $vkeys=$hash{"$scope:keys:$rid"};
2983: my @keys=split(/:/,$vkeys);
2984: my $key;
2985: $qresult.="$scope:keys=$vkeys&";
2986: foreach $key (@keys) {
2987: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
2988: }
2989: }
2990: if (untie(%hash)) {
2991: $qresult=~s/\&$//;
2992: print $client "$qresult\n";
2993: } else {
2994: print $client "error: ".($!+0)
2995: ." untie(GDBM) Failed ".
2996: "while attempting restore\n";
2997: }
2998: } else {
2999: print $client "error: ".($!+0)
3000: ." tie(GDBM) Failed ".
3001: "while attempting restore\n";
3002: }
3003: } else {
3004: Reply($client, "refused\n", $userinput);
3005:
3006: }
3007: # -------------------------------------------------------------------- chatsend
3008: } elsif ($userinput =~ /^chatsend/) {
3009: if(isClient) {
3010: my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
3011: &chatadd($cdom,$cnum,$newpost);
3012: print $client "ok\n";
3013: } else {
3014: Reply($client, "refused\n", $userinput);
3015:
3016: }
3017: # -------------------------------------------------------------------- chatretr
3018: } elsif ($userinput =~ /^chatretr/) {
3019: if(isClient) {
3020: my
3021: ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
3022: my $reply='';
3023: foreach (&getchat($cdom,$cnum,$udom,$uname)) {
3024: $reply.=&escape($_).':';
3025: }
3026: $reply=~s/\:$//;
3027: print $client $reply."\n";
3028: } else {
3029: Reply($client, "refused\n", $userinput);
3030:
3031: }
3032: # ------------------------------------------------------------------- querysend
3033: } elsif ($userinput =~ /^querysend/) {
1.193 raeburn 3034: if (isClient) {
1.178 foxr 3035: my ($cmd,$query,
3036: $arg1,$arg2,$arg3)=split(/\:/,$userinput);
3037: $query=~s/\n*$//g;
3038: print $client "".
3039: sqlreply("$clientname\&$query".
3040: "\&$arg1"."\&$arg2"."\&$arg3")."\n";
3041: } else {
3042: Reply($client, "refused\n", $userinput);
3043:
3044: }
3045: # ------------------------------------------------------------------ queryreply
3046: } elsif ($userinput =~ /^queryreply/) {
3047: if(isClient) {
3048: my ($cmd,$id,$reply)=split(/:/,$userinput);
3049: my $store;
3050: my $execdir=$perlvar{'lonDaemons'};
3051: if ($store=IO::File->new(">$execdir/tmp/$id")) {
3052: $reply=~s/\&/\n/g;
3053: print $store $reply;
3054: close $store;
3055: my $store2=IO::File->new(">$execdir/tmp/$id.end");
3056: print $store2 "done\n";
3057: close $store2;
3058: print $client "ok\n";
3059: }
3060: else {
3061: print $client "error: ".($!+0)
3062: ." IO::File->new Failed ".
3063: "while attempting queryreply\n";
3064: }
3065: } else {
3066: Reply($client, "refused\n", $userinput);
3067:
3068: }
3069: # ----------------------------------------------------------------- courseidput
3070: } elsif ($userinput =~ /^courseidput/) {
3071: if(isClient) {
3072: my ($cmd,$udom,$what)=split(/:/,$userinput);
3073: chomp($what);
3074: $udom=~s/\W//g;
3075: my $proname=
3076: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
3077: my $now=time;
3078: my @pairs=split(/\&/,$what);
3079: my %hash;
3080: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
3081: foreach my $pair (@pairs) {
1.202 raeburn 3082: my ($key,$descr,$inst_code)=split(/=/,$pair);
3083: $hash{$key}=$descr.':'.$inst_code.':'.$now;
1.178 foxr 3084: }
3085: if (untie(%hash)) {
3086: print $client "ok\n";
3087: } else {
3088: print $client "error: ".($!+0)
3089: ." untie(GDBM) Failed ".
3090: "while attempting courseidput\n";
3091: }
3092: } else {
3093: print $client "error: ".($!+0)
3094: ." tie(GDBM) Failed ".
3095: "while attempting courseidput\n";
3096: }
3097: } else {
3098: Reply($client, "refused\n", $userinput);
3099:
3100: }
3101: # ---------------------------------------------------------------- courseiddump
3102: } elsif ($userinput =~ /^courseiddump/) {
3103: if(isClient) {
3104: my ($cmd,$udom,$since,$description)
3105: =split(/:/,$userinput);
3106: if (defined($description)) {
3107: $description=&unescape($description);
3108: } else {
3109: $description='.';
3110: }
3111: unless (defined($since)) { $since=0; }
3112: my $qresult='';
3113: my $proname=
3114: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
3115: my %hash;
3116: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
3117: while (my ($key,$value) = each(%hash)) {
1.202 raeburn 3118: my ($descr,$lasttime,$inst_code);
3119: if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {
3120: ($descr,$inst_code,$lasttime)=($1,$2,$3);
3121: } else {
3122: ($descr,$lasttime) = split(/\:/,$value);
3123: }
1.178 foxr 3124: if ($lasttime<$since) { next; }
3125: if ($description eq '.') {
1.202 raeburn 3126: $qresult.=$key.'='.$descr.':'.$inst_code.'&';
1.178 foxr 3127: } else {
3128: my $unescapeVal = &unescape($descr);
1.189 www 3129: if (eval('$unescapeVal=~/\Q$description\E/i')) {
1.202 raeburn 3130: $qresult.=$key.'='.$descr.':'.$inst_code.'&';
1.178 foxr 3131: }
3132: }
3133: }
3134: if (untie(%hash)) {
3135: chop($qresult);
3136: print $client "$qresult\n";
3137: } else {
3138: print $client "error: ".($!+0)
3139: ." untie(GDBM) Failed ".
3140: "while attempting courseiddump\n";
3141: }
3142: } else {
3143: print $client "error: ".($!+0)
3144: ." tie(GDBM) Failed ".
3145: "while attempting courseiddump\n";
3146: }
3147: } else {
3148: Reply($client, "refused\n", $userinput);
3149:
3150: }
3151: # ----------------------------------------------------------------------- idput
3152: } elsif ($userinput =~ /^idput/) {
3153: if(isClient) {
3154: my ($cmd,$udom,$what)=split(/:/,$userinput);
3155: chomp($what);
3156: $udom=~s/\W//g;
3157: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
3158: my $now=time;
3159: my @pairs=split(/\&/,$what);
3160: my %hash;
3161: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
1.209 ! albertel 3162: {
! 3163: my $hfh;
! 3164: if ($hfh=IO::File->new(">>$proname.hist")) {
! 3165: print $hfh "P:$now:$what\n";
! 3166: }
! 3167: }
1.178 foxr 3168: foreach my $pair (@pairs) {
3169: my ($key,$value)=split(/=/,$pair);
3170: $hash{$key}=$value;
3171: }
3172: if (untie(%hash)) {
3173: print $client "ok\n";
3174: } else {
3175: print $client "error: ".($!+0)
3176: ." untie(GDBM) Failed ".
3177: "while attempting idput\n";
3178: }
3179: } else {
3180: print $client "error: ".($!+0)
3181: ." tie(GDBM) Failed ".
3182: "while attempting idput\n";
3183: }
3184: } else {
3185: Reply($client, "refused\n", $userinput);
3186:
3187: }
3188: # ----------------------------------------------------------------------- idget
3189: } elsif ($userinput =~ /^idget/) {
3190: if(isClient) {
3191: my ($cmd,$udom,$what)=split(/:/,$userinput);
3192: chomp($what);
3193: $udom=~s/\W//g;
3194: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
3195: my @queries=split(/\&/,$what);
3196: my $qresult='';
3197: my %hash;
3198: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
3199: for (my $i=0;$i<=$#queries;$i++) {
3200: $qresult.="$hash{$queries[$i]}&";
3201: }
3202: if (untie(%hash)) {
3203: $qresult=~s/\&$//;
3204: print $client "$qresult\n";
3205: } else {
3206: print $client "error: ".($!+0)
3207: ." untie(GDBM) Failed ".
3208: "while attempting idget\n";
3209: }
3210: } else {
3211: print $client "error: ".($!+0)
3212: ." tie(GDBM) Failed ".
3213: "while attempting idget\n";
3214: }
3215: } else {
3216: Reply($client, "refused\n", $userinput);
3217:
3218: }
3219: # ---------------------------------------------------------------------- tmpput
3220: } elsif ($userinput =~ /^tmpput/) {
3221: if(isClient) {
3222: my ($cmd,$what)=split(/:/,$userinput);
3223: my $store;
3224: $tmpsnum++;
3225: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
3226: $id=~s/\W/\_/g;
3227: $what=~s/\n//g;
3228: my $execdir=$perlvar{'lonDaemons'};
3229: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
3230: print $store $what;
3231: close $store;
3232: print $client "$id\n";
3233: }
3234: else {
3235: print $client "error: ".($!+0)
3236: ."IO::File->new Failed ".
3237: "while attempting tmpput\n";
3238: }
3239: } else {
3240: Reply($client, "refused\n", $userinput);
3241:
3242: }
3243:
3244: # ---------------------------------------------------------------------- tmpget
3245: } elsif ($userinput =~ /^tmpget/) {
3246: if(isClient) {
3247: my ($cmd,$id)=split(/:/,$userinput);
3248: chomp($id);
3249: $id=~s/\W/\_/g;
3250: my $store;
3251: my $execdir=$perlvar{'lonDaemons'};
3252: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
3253: my $reply=<$store>;
3254: print $client "$reply\n";
3255: close $store;
3256: }
3257: else {
3258: print $client "error: ".($!+0)
3259: ."IO::File->new Failed ".
3260: "while attempting tmpget\n";
3261: }
3262: } else {
3263: Reply($client, "refused\n", $userinput);
3264:
3265: }
3266: # ---------------------------------------------------------------------- tmpdel
3267: } elsif ($userinput =~ /^tmpdel/) {
3268: if(isClient) {
3269: my ($cmd,$id)=split(/:/,$userinput);
3270: chomp($id);
3271: $id=~s/\W/\_/g;
3272: my $execdir=$perlvar{'lonDaemons'};
3273: if (unlink("$execdir/tmp/$id.tmp")) {
3274: print $client "ok\n";
3275: } else {
3276: print $client "error: ".($!+0)
3277: ."Unlink tmp Failed ".
3278: "while attempting tmpdel\n";
3279: }
3280: } else {
3281: Reply($client, "refused\n", $userinput);
3282:
3283: }
1.201 matthew 3284: # ----------------------------------------- portfolio directory list (portls)
3285: } elsif ($userinput =~ /^portls/) {
3286: if(isClient) {
3287: my ($cmd,$uname,$udom)=split(/:/,$userinput);
3288: my $udir=propath($udom,$uname).'/userfiles/portfolio';
3289: my $dirLine='';
3290: my $dirContents='';
3291: if (opendir(LSDIR,$udir.'/')){
3292: while ($dirLine = readdir(LSDIR)){
3293: $dirContents = $dirContents.$dirLine.'<br />';
3294: }
3295: } else {
3296: $dirContents = "No directory found\n";
3297: }
3298: print $client $dirContents."\n";
3299: } else {
3300: Reply($client, "refused\n", $userinput);
3301: }
1.178 foxr 3302: # -------------------------------------------------------------------------- ls
3303: } elsif ($userinput =~ /^ls/) {
3304: if(isClient) {
3305: my $obs;
3306: my $rights;
3307: my ($cmd,$ulsdir)=split(/:/,$userinput);
3308: my $ulsout='';
3309: my $ulsfn;
3310: if (-e $ulsdir) {
3311: if(-d $ulsdir) {
3312: if (opendir(LSDIR,$ulsdir)) {
3313: while ($ulsfn=readdir(LSDIR)) {
3314: undef $obs, $rights;
3315: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
3316: #We do some obsolete checking here
3317: if(-e $ulsdir.'/'.$ulsfn.".meta") {
3318: open(FILE, $ulsdir.'/'.$ulsfn.".meta");
3319: my @obsolete=<FILE>;
3320: foreach my $obsolete (@obsolete) {
3321: if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }
3322: if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
3323: }
3324: }
3325: $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
3326: if($obs eq '1') { $ulsout.="&1"; }
3327: else { $ulsout.="&0"; }
3328: if($rights eq '1') { $ulsout.="&1:"; }
3329: else { $ulsout.="&0:"; }
3330: }
3331: closedir(LSDIR);
3332: }
3333: } else {
3334: my @ulsstats=stat($ulsdir);
3335: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
3336: }
3337: } else {
3338: $ulsout='no_such_dir';
3339: }
3340: if ($ulsout eq '') { $ulsout='empty'; }
3341: print $client "$ulsout\n";
3342: } else {
3343: Reply($client, "refused\n", $userinput);
3344:
3345: }
3346: # ----------------------------------------------------------------- setannounce
3347: } elsif ($userinput =~ /^setannounce/) {
3348: if (isClient) {
3349: my ($cmd,$announcement)=split(/:/,$userinput);
3350: chomp($announcement);
3351: $announcement=&unescape($announcement);
3352: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
3353: '/announcement.txt')) {
3354: print $store $announcement;
3355: close $store;
3356: print $client "ok\n";
3357: } else {
3358: print $client "error: ".($!+0)."\n";
3359: }
3360: } else {
3361: Reply($client, "refused\n", $userinput);
3362:
3363: }
3364: # ------------------------------------------------------------------ Hanging up
3365: } elsif (($userinput =~ /^exit/) ||
3366: ($userinput =~ /^init/)) { # no restrictions.
3367: &logthis(
3368: "Client $clientip ($clientname) hanging up: $userinput");
3369: print $client "bye\n";
3370: $client->shutdown(2); # shutdown the socket forcibly.
3371: $client->close();
3372: last;
1.161 foxr 3373:
1.178 foxr 3374: # ---------------------------------- set current host/domain
3375: } elsif ($userinput =~ /^sethost:/) {
3376: if (isClient) {
3377: print $client &sethost($userinput)."\n";
3378: } else {
3379: print $client "refused\n";
3380: }
3381: #---------------------------------- request file (?) version.
3382: } elsif ($userinput =~/^version:/) {
3383: if (isClient) {
3384: print $client &version($userinput)."\n";
3385: } else {
3386: print $client "refused\n";
3387: }
1.193 raeburn 3388: #------------------------------- is auto-enrollment enabled?
1.200 matthew 3389: } elsif ($userinput =~/^autorun:/) {
1.193 raeburn 3390: if (isClient) {
1.200 matthew 3391: my ($cmd,$cdom) = split(/:/,$userinput);
3392: my $outcome = &localenroll::run($cdom);
1.193 raeburn 3393: print $client "$outcome\n";
3394: } else {
3395: print $client "0\n";
3396: }
3397: #------------------------------- get official sections (for auto-enrollment).
1.200 matthew 3398: } elsif ($userinput =~/^autogetsections:/) {
1.193 raeburn 3399: if (isClient) {
1.200 matthew 3400: my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
3401: my @secs = &localenroll::get_sections($coursecode,$cdom);
1.193 raeburn 3402: my $seclist = &escape(join(':',@secs));
3403: print $client "$seclist\n";
3404: } else {
3405: print $client "refused\n";
3406: }
3407: #----------------------- validate owner of new course section (for auto-enrollment).
1.200 matthew 3408: } elsif ($userinput =~/^autonewcourse:/) {
1.193 raeburn 3409: if (isClient) {
1.200 matthew 3410: my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
3411: my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
1.193 raeburn 3412: print $client "$outcome\n";
3413: } else {
3414: print $client "refused\n";
3415: }
3416: #-------------- validate course section in schedule of classes (for auto-enrollment).
1.200 matthew 3417: } elsif ($userinput =~/^autovalidatecourse:/) {
1.193 raeburn 3418: if (isClient) {
1.200 matthew 3419: my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
3420: my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
1.193 raeburn 3421: print $client "$outcome\n";
3422: } else {
3423: print $client "refused\n";
3424: }
3425: #--------------------------- create password for new user (for auto-enrollment).
1.200 matthew 3426: } elsif ($userinput =~/^autocreatepassword:/) {
1.193 raeburn 3427: if (isClient) {
1.200 matthew 3428: my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
3429: my ($create_passwd,$authchk);
3430: ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);
1.193 raeburn 3431: print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
3432: } else {
3433: print $client "refused\n";
3434: }
3435: #--------------------------- read and remove temporary files (for auto-enrollment).
1.200 matthew 3436: } elsif ($userinput =~/^autoretrieve:/) {
1.193 raeburn 3437: if (isClient) {
3438: my ($cmd,$filename) = split(/:/,$userinput);
3439: my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
3440: if ( (-e $source) && ($filename ne '') ) {
3441: my $reply = '';
3442: if (open(my $fh,$source)) {
3443: while (<$fh>) {
3444: chomp($_);
3445: $_ =~ s/^\s+//g;
3446: $_ =~ s/\s+$//g;
3447: $reply .= $_;
3448: }
3449: close($fh);
3450: print $client &escape($reply)."\n";
3451: # unlink($source);
3452: } else {
3453: print $client "error\n";
3454: }
3455: } else {
3456: print $client "error\n";
3457: }
3458: } else {
3459: print $client "refused\n";
3460: }
1.205 raeburn 3461: #--------------------- read and retrieve institutional code format (for support form).
3462: } elsif ($userinput =~/^autoinstcodeformat:/) {
3463: if (isClient) {
3464: my $reply;
3465: my($cmd,$cdom,$course) = split(/:/,$userinput);
3466: my @pairs = split/\&/,$course;
3467: my %instcodes = ();
3468: my %codes = ();
3469: my @codetitles = ();
3470: my %cat_titles = ();
3471: my %cat_order = ();
3472: foreach (@pairs) {
3473: my ($key,$value) = split/=/,$_;
3474: $instcodes{&unescape($key)} = &unescape($value);
3475: }
3476: my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order);
3477: if ($formatreply eq 'ok') {
3478: my $codes_str = &hash2str(%codes);
3479: my $codetitles_str = &array2str(@codetitles);
3480: my $cat_titles_str = &hash2str(%cat_titles);
3481: my $cat_order_str = &hash2str(%cat_order);
3482: print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";
3483: }
3484: } else {
3485: print $client "refused\n";
3486: }
1.178 foxr 3487: # ------------------------------------------------------------- unknown command
1.161 foxr 3488:
1.178 foxr 3489: } else {
3490: # unknown command
3491: print $client "unknown_cmd\n";
3492: }
1.177 foxr 3493: # -------------------------------------------------------------------- complete
1.178 foxr 3494: alarm(0);
1.200 matthew 3495: &status('Listening to '.$clientname." ($keymode)");
1.161 foxr 3496: }
1.59 www 3497: # --------------------------------------------- client unknown or fishy, refuse
1.161 foxr 3498: } else {
3499: print $client "refused\n";
3500: $client->close();
1.190 albertel 3501: &logthis("<font color='blue'>WARNING: "
1.161 foxr 3502: ."Rejected client $clientip, closing connection</font>");
3503: }
3504: }
3505:
1.1 albertel 3506: # =============================================================================
1.161 foxr 3507:
1.190 albertel 3508: &logthis("<font color='red'>CRITICAL: "
1.161 foxr 3509: ."Disconnect from $clientip ($clientname)</font>");
3510:
3511:
3512: # this exit is VERY important, otherwise the child will become
3513: # a producer of more and more children, forking yourself into
3514: # process death.
3515: exit;
1.106 foxr 3516:
1.78 foxr 3517: }
3518:
3519:
3520: #
3521: # Checks to see if the input roleput request was to set
3522: # an author role. If so, invokes the lchtmldir script to set
3523: # up a correct public_html
3524: # Parameters:
3525: # request - The request sent to the rolesput subchunk.
3526: # We're looking for /domain/_au
3527: # domain - The domain in which the user is having roles doctored.
3528: # user - Name of the user for which the role is being put.
3529: # authtype - The authentication type associated with the user.
3530: #
3531: sub ManagePermissions
3532: {
1.192 foxr 3533:
3534: my ($request, $domain, $user, $authtype) = @_;
1.78 foxr 3535:
3536: # See if the request is of the form /$domain/_au
3537: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
3538: my $execdir = $perlvar{'lonDaemons'};
3539: my $userhome= "/home/$user" ;
1.134 albertel 3540: &logthis("system $execdir/lchtmldir $userhome $user $authtype");
1.78 foxr 3541: system("$execdir/lchtmldir $userhome $user $authtype");
3542: }
3543: }
3544: #
3545: # GetAuthType - Determines the authorization type of a user in a domain.
3546:
3547: # Returns the authorization type or nouser if there is no such user.
3548: #
3549: sub GetAuthType
3550: {
1.192 foxr 3551:
3552: my ($domain, $user) = @_;
1.78 foxr 3553:
1.79 foxr 3554: Debug("GetAuthType( $domain, $user ) \n");
1.78 foxr 3555: my $proname = &propath($domain, $user);
3556: my $passwdfile = "$proname/passwd";
3557: if( -e $passwdfile ) {
3558: my $pf = IO::File->new($passwdfile);
3559: my $realpassword = <$pf>;
3560: chomp($realpassword);
1.79 foxr 3561: Debug("Password info = $realpassword\n");
1.78 foxr 3562: my ($authtype, $contentpwd) = split(/:/, $realpassword);
1.79 foxr 3563: Debug("Authtype = $authtype, content = $contentpwd\n");
1.78 foxr 3564: my $availinfo = '';
1.91 albertel 3565: if($authtype eq 'krb4' or $authtype eq 'krb5') {
1.78 foxr 3566: $availinfo = $contentpwd;
3567: }
1.79 foxr 3568:
1.78 foxr 3569: return "$authtype:$availinfo";
3570: }
3571: else {
1.79 foxr 3572: Debug("Returning nouser");
1.78 foxr 3573: return "nouser";
3574: }
1.1 albertel 3575: }
3576:
1.84 albertel 3577: sub addline {
3578: my ($fname,$hostid,$ip,$newline)=@_;
3579: my $contents;
3580: my $found=0;
3581: my $expr='^'.$hostid.':'.$ip.':';
3582: $expr =~ s/\./\\\./g;
1.134 albertel 3583: my $sh;
1.84 albertel 3584: if ($sh=IO::File->new("$fname.subscription")) {
3585: while (my $subline=<$sh>) {
3586: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
3587: }
3588: $sh->close();
3589: }
3590: $sh=IO::File->new(">$fname.subscription");
3591: if ($contents) { print $sh $contents; }
3592: if ($newline) { print $sh $newline; }
3593: $sh->close();
3594: return $found;
1.86 www 3595: }
3596:
3597: sub getchat {
1.122 www 3598: my ($cdom,$cname,$udom,$uname)=@_;
1.87 www 3599: my %hash;
3600: my $proname=&propath($cdom,$cname);
3601: my @entries=();
1.88 albertel 3602: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
3603: &GDBM_READER(),0640)) {
3604: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
3605: untie %hash;
1.123 www 3606: }
1.124 www 3607: my @participants=();
1.134 albertel 3608: my $cutoff=time-60;
1.123 www 3609: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
1.124 www 3610: &GDBM_WRCREAT(),0640)) {
3611: $hash{$uname.':'.$udom}=time;
1.123 www 3612: foreach (sort keys %hash) {
3613: if ($hash{$_}>$cutoff) {
1.124 www 3614: $participants[$#participants+1]='active_participant:'.$_;
1.123 www 3615: }
3616: }
3617: untie %hash;
1.86 www 3618: }
1.124 www 3619: return (@participants,@entries);
1.86 www 3620: }
3621:
3622: sub chatadd {
1.88 albertel 3623: my ($cdom,$cname,$newchat)=@_;
3624: my %hash;
3625: my $proname=&propath($cdom,$cname);
3626: my @entries=();
1.142 www 3627: my $time=time;
1.88 albertel 3628: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
3629: &GDBM_WRCREAT(),0640)) {
3630: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
3631: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
3632: my ($thentime,$idnum)=split(/\_/,$lastid);
3633: my $newid=$time.'_000000';
3634: if ($thentime==$time) {
3635: $idnum=~s/^0+//;
3636: $idnum++;
3637: $idnum=substr('000000'.$idnum,-6,6);
3638: $newid=$time.'_'.$idnum;
3639: }
3640: $hash{$newid}=$newchat;
3641: my $expired=$time-3600;
3642: foreach (keys %hash) {
3643: my ($thistime)=($_=~/(\d+)\_/);
3644: if ($thistime<$expired) {
1.89 www 3645: delete $hash{$_};
1.88 albertel 3646: }
3647: }
3648: untie %hash;
1.142 www 3649: }
3650: {
3651: my $hfh;
3652: if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
3653: print $hfh "$time:".&unescape($newchat)."\n";
3654: }
1.86 www 3655: }
1.84 albertel 3656: }
3657:
3658: sub unsub {
3659: my ($fname,$clientip)=@_;
3660: my $result;
1.188 foxr 3661: my $unsubs = 0; # Number of successful unsubscribes:
3662:
3663:
3664: # An old way subscriptions were handled was to have a
3665: # subscription marker file:
3666:
3667: Debug("Attempting unlink of $fname.$clientname");
1.161 foxr 3668: if (unlink("$fname.$clientname")) {
1.188 foxr 3669: $unsubs++; # Successful unsub via marker file.
3670: }
3671:
3672: # The more modern way to do it is to have a subscription list
3673: # file:
3674:
1.84 albertel 3675: if (-e "$fname.subscription") {
1.161 foxr 3676: my $found=&addline($fname,$clientname,$clientip,'');
1.188 foxr 3677: if ($found) {
3678: $unsubs++;
3679: }
3680: }
3681:
3682: # If either or both of these mechanisms succeeded in unsubscribing a
3683: # resource we can return ok:
3684:
3685: if($unsubs) {
3686: $result = "ok\n";
1.84 albertel 3687: } else {
1.188 foxr 3688: $result = "not_subscribed\n";
1.84 albertel 3689: }
1.188 foxr 3690:
1.84 albertel 3691: return $result;
3692: }
3693:
1.101 www 3694: sub currentversion {
3695: my $fname=shift;
3696: my $version=-1;
3697: my $ulsdir='';
3698: if ($fname=~/^(.+)\/[^\/]+$/) {
3699: $ulsdir=$1;
3700: }
1.114 albertel 3701: my ($fnamere1,$fnamere2);
3702: # remove version if already specified
1.101 www 3703: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
1.114 albertel 3704: # get the bits that go before and after the version number
3705: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
3706: $fnamere1=$1;
3707: $fnamere2='.'.$2;
3708: }
1.101 www 3709: if (-e $fname) { $version=1; }
3710: if (-e $ulsdir) {
1.134 albertel 3711: if(-d $ulsdir) {
3712: if (opendir(LSDIR,$ulsdir)) {
3713: my $ulsfn;
3714: while ($ulsfn=readdir(LSDIR)) {
1.101 www 3715: # see if this is a regular file (ignore links produced earlier)
1.134 albertel 3716: my $thisfile=$ulsdir.'/'.$ulsfn;
3717: unless (-l $thisfile) {
1.160 www 3718: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) {
1.134 albertel 3719: if ($1>$version) { $version=$1; }
3720: }
3721: }
3722: }
3723: closedir(LSDIR);
3724: $version++;
3725: }
3726: }
3727: }
3728: return $version;
1.101 www 3729: }
3730:
3731: sub thisversion {
3732: my $fname=shift;
3733: my $version=-1;
3734: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
3735: $version=$1;
3736: }
3737: return $version;
3738: }
3739:
1.84 albertel 3740: sub subscribe {
3741: my ($userinput,$clientip)=@_;
3742: my $result;
3743: my ($cmd,$fname)=split(/:/,$userinput);
3744: my $ownership=&ishome($fname);
3745: if ($ownership eq 'owner') {
1.101 www 3746: # explitly asking for the current version?
3747: unless (-e $fname) {
3748: my $currentversion=¤tversion($fname);
3749: if (&thisversion($fname)==$currentversion) {
3750: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
3751: my $root=$1;
3752: my $extension=$2;
3753: symlink($root.'.'.$extension,
3754: $root.'.'.$currentversion.'.'.$extension);
1.102 www 3755: unless ($extension=~/\.meta$/) {
3756: symlink($root.'.'.$extension.'.meta',
3757: $root.'.'.$currentversion.'.'.$extension.'.meta');
3758: }
1.101 www 3759: }
3760: }
3761: }
1.84 albertel 3762: if (-e $fname) {
3763: if (-d $fname) {
3764: $result="directory\n";
3765: } else {
1.161 foxr 3766: if (-e "$fname.$clientname") {&unsub($fname,$clientip);}
1.134 albertel 3767: my $now=time;
1.161 foxr 3768: my $found=&addline($fname,$clientname,$clientip,
3769: "$clientname:$clientip:$now\n");
1.84 albertel 3770: if ($found) { $result="$fname\n"; }
3771: # if they were subscribed to only meta data, delete that
3772: # subscription, when you subscribe to a file you also get
3773: # the metadata
3774: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
3775: $fname=~s/\/home\/httpd\/html\/res/raw/;
3776: $fname="http://$thisserver/".$fname;
3777: $result="$fname\n";
3778: }
3779: } else {
3780: $result="not_found\n";
3781: }
3782: } else {
3783: $result="rejected\n";
3784: }
3785: return $result;
3786: }
1.91 albertel 3787:
3788: sub make_passwd_file {
1.98 foxr 3789: my ($uname, $umode,$npass,$passfilename)=@_;
1.91 albertel 3790: my $result="ok\n";
3791: if ($umode eq 'krb4' or $umode eq 'krb5') {
3792: {
3793: my $pf = IO::File->new(">$passfilename");
3794: print $pf "$umode:$npass\n";
3795: }
3796: } elsif ($umode eq 'internal') {
3797: my $salt=time;
3798: $salt=substr($salt,6,2);
3799: my $ncpass=crypt($npass,$salt);
3800: {
3801: &Debug("Creating internal auth");
3802: my $pf = IO::File->new(">$passfilename");
3803: print $pf "internal:$ncpass\n";
3804: }
3805: } elsif ($umode eq 'localauth') {
3806: {
3807: my $pf = IO::File->new(">$passfilename");
3808: print $pf "localauth:$npass\n";
3809: }
3810: } elsif ($umode eq 'unix') {
3811: {
1.186 foxr 3812: #
3813: # Don't allow the creation of privileged accounts!!! that would
3814: # be real bad!!!
3815: #
3816: my $uid = getpwnam($uname);
3817: if((defined $uid) && ($uid == 0)) {
3818: &logthis(">>>Attempted to create privilged account blocked");
3819: return "no_priv_account_error\n";
3820: }
3821:
1.91 albertel 3822: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
3823: {
3824: &Debug("Executing external: ".$execpath);
1.98 foxr 3825: &Debug("user = ".$uname.", Password =". $npass);
1.132 matthew 3826: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
1.91 albertel 3827: print $se "$uname\n";
3828: print $se "$npass\n";
3829: print $se "$npass\n";
1.97 foxr 3830: }
3831: my $useraddok = $?;
3832: if($useraddok > 0) {
3833: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
1.91 albertel 3834: }
3835: my $pf = IO::File->new(">$passfilename");
3836: print $pf "unix:\n";
3837: }
3838: } elsif ($umode eq 'none') {
3839: {
3840: my $pf = IO::File->new(">$passfilename");
3841: print $pf "none:\n";
3842: }
3843: } else {
3844: $result="auth_mode_error\n";
3845: }
3846: return $result;
1.121 albertel 3847: }
3848:
3849: sub sethost {
3850: my ($remotereq) = @_;
3851: my (undef,$hostid)=split(/:/,$remotereq);
3852: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
3853: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
1.200 matthew 3854: $currenthostid =$hostid;
1.121 albertel 3855: $currentdomainid=$hostdom{$hostid};
3856: &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
3857: } else {
3858: &logthis("Requested host id $hostid not an alias of ".
3859: $perlvar{'lonHostID'}." refusing connection");
3860: return 'unable_to_set';
3861: }
3862: return 'ok';
3863: }
3864:
3865: sub version {
3866: my ($userinput)=@_;
3867: $remoteVERSION=(split(/:/,$userinput))[1];
3868: return "version:$VERSION";
1.127 albertel 3869: }
1.178 foxr 3870:
1.128 albertel 3871: #There is a copy of this in lonnet.pm
1.127 albertel 3872: sub userload {
3873: my $numusers=0;
3874: {
3875: opendir(LONIDS,$perlvar{'lonIDsDir'});
3876: my $filename;
3877: my $curtime=time;
3878: while ($filename=readdir(LONIDS)) {
3879: if ($filename eq '.' || $filename eq '..') {next;}
1.138 albertel 3880: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
1.159 albertel 3881: if ($curtime-$mtime < 1800) { $numusers++; }
1.127 albertel 3882: }
3883: closedir(LONIDS);
3884: }
3885: my $userloadpercent=0;
3886: my $maxuserload=$perlvar{'lonUserLoadLim'};
3887: if ($maxuserload) {
1.129 albertel 3888: $userloadpercent=100*$numusers/$maxuserload;
1.127 albertel 3889: }
1.130 albertel 3890: $userloadpercent=sprintf("%.2f",$userloadpercent);
1.127 albertel 3891: return $userloadpercent;
1.91 albertel 3892: }
3893:
1.205 raeburn 3894: # Routines for serializing arrays and hashes (copies from lonnet)
3895:
3896: sub array2str {
3897: my (@array) = @_;
3898: my $result=&arrayref2str(\@array);
3899: $result=~s/^__ARRAY_REF__//;
3900: $result=~s/__END_ARRAY_REF__$//;
3901: return $result;
3902: }
3903:
3904: sub arrayref2str {
3905: my ($arrayref) = @_;
3906: my $result='__ARRAY_REF__';
3907: foreach my $elem (@$arrayref) {
3908: if(ref($elem) eq 'ARRAY') {
3909: $result.=&arrayref2str($elem).'&';
3910: } elsif(ref($elem) eq 'HASH') {
3911: $result.=&hashref2str($elem).'&';
3912: } elsif(ref($elem)) {
3913: #print("Got a ref of ".(ref($elem))." skipping.");
3914: } else {
3915: $result.=&escape($elem).'&';
3916: }
3917: }
3918: $result=~s/\&$//;
3919: $result .= '__END_ARRAY_REF__';
3920: return $result;
3921: }
3922:
3923: sub hash2str {
3924: my (%hash) = @_;
3925: my $result=&hashref2str(\%hash);
3926: $result=~s/^__HASH_REF__//;
3927: $result=~s/__END_HASH_REF__$//;
3928: return $result;
3929: }
3930:
3931: sub hashref2str {
3932: my ($hashref)=@_;
3933: my $result='__HASH_REF__';
3934: foreach (sort(keys(%$hashref))) {
3935: if (ref($_) eq 'ARRAY') {
3936: $result.=&arrayref2str($_).'=';
3937: } elsif (ref($_) eq 'HASH') {
3938: $result.=&hashref2str($_).'=';
3939: } elsif (ref($_)) {
3940: $result.='=';
3941: #print("Got a ref of ".(ref($_))." skipping.");
3942: } else {
3943: if ($_) {$result.=&escape($_).'=';} else { last; }
3944: }
3945:
3946: if(ref($hashref->{$_}) eq 'ARRAY') {
3947: $result.=&arrayref2str($hashref->{$_}).'&';
3948: } elsif(ref($hashref->{$_}) eq 'HASH') {
3949: $result.=&hashref2str($hashref->{$_}).'&';
3950: } elsif(ref($hashref->{$_})) {
3951: $result.='&';
3952: #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
3953: } else {
3954: $result.=&escape($hashref->{$_}).'&';
3955: }
3956: }
3957: $result=~s/\&$//;
3958: $result .= '__END_HASH_REF__';
3959: return $result;
3960: }
1.200 matthew 3961:
1.61 harris41 3962: # ----------------------------------- POD (plain old documentation, CPAN style)
3963:
3964: =head1 NAME
3965:
3966: lond - "LON Daemon" Server (port "LOND" 5663)
3967:
3968: =head1 SYNOPSIS
3969:
1.74 harris41 3970: Usage: B<lond>
3971:
3972: Should only be run as user=www. This is a command-line script which
3973: is invoked by B<loncron>. There is no expectation that a typical user
3974: will manually start B<lond> from the command-line. (In other words,
3975: DO NOT START B<lond> YOURSELF.)
1.61 harris41 3976:
3977: =head1 DESCRIPTION
3978:
1.74 harris41 3979: There are two characteristics associated with the running of B<lond>,
3980: PROCESS MANAGEMENT (starting, stopping, handling child processes)
3981: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
3982: subscriptions, etc). These are described in two large
3983: sections below.
3984:
3985: B<PROCESS MANAGEMENT>
3986:
1.61 harris41 3987: Preforker - server who forks first. Runs as a daemon. HUPs.
3988: Uses IDEA encryption
3989:
1.74 harris41 3990: B<lond> forks off children processes that correspond to the other servers
3991: in the network. Management of these processes can be done at the
3992: parent process level or the child process level.
3993:
3994: B<logs/lond.log> is the location of log messages.
3995:
3996: The process management is now explained in terms of linux shell commands,
3997: subroutines internal to this code, and signal assignments:
3998:
3999: =over 4
4000:
4001: =item *
4002:
4003: PID is stored in B<logs/lond.pid>
4004:
4005: This is the process id number of the parent B<lond> process.
4006:
4007: =item *
4008:
4009: SIGTERM and SIGINT
4010:
4011: Parent signal assignment:
4012: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
4013:
4014: Child signal assignment:
4015: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
4016: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
4017: to restart a new child.)
4018:
4019: Command-line invocations:
4020: B<kill> B<-s> SIGTERM I<PID>
4021: B<kill> B<-s> SIGINT I<PID>
4022:
4023: Subroutine B<HUNTSMAN>:
4024: This is only invoked for the B<lond> parent I<PID>.
4025: This kills all the children, and then the parent.
4026: The B<lonc.pid> file is cleared.
4027:
4028: =item *
4029:
4030: SIGHUP
4031:
4032: Current bug:
4033: This signal can only be processed the first time
4034: on the parent process. Subsequent SIGHUP signals
4035: have no effect.
4036:
4037: Parent signal assignment:
4038: $SIG{HUP} = \&HUPSMAN;
4039:
4040: Child signal assignment:
4041: none (nothing happens)
4042:
4043: Command-line invocations:
4044: B<kill> B<-s> SIGHUP I<PID>
4045:
4046: Subroutine B<HUPSMAN>:
4047: This is only invoked for the B<lond> parent I<PID>,
4048: This kills all the children, and then the parent.
4049: The B<lond.pid> file is cleared.
4050:
4051: =item *
4052:
4053: SIGUSR1
4054:
4055: Parent signal assignment:
4056: $SIG{USR1} = \&USRMAN;
4057:
4058: Child signal assignment:
4059: $SIG{USR1}= \&logstatus;
4060:
4061: Command-line invocations:
4062: B<kill> B<-s> SIGUSR1 I<PID>
4063:
4064: Subroutine B<USRMAN>:
4065: When invoked for the B<lond> parent I<PID>,
4066: SIGUSR1 is sent to all the children, and the status of
4067: each connection is logged.
1.144 foxr 4068:
4069: =item *
4070:
4071: SIGUSR2
4072:
4073: Parent Signal assignment:
4074: $SIG{USR2} = \&UpdateHosts
4075:
4076: Child signal assignment:
4077: NONE
4078:
1.74 harris41 4079:
4080: =item *
4081:
4082: SIGCHLD
4083:
4084: Parent signal assignment:
4085: $SIG{CHLD} = \&REAPER;
4086:
4087: Child signal assignment:
4088: none
4089:
4090: Command-line invocations:
4091: B<kill> B<-s> SIGCHLD I<PID>
4092:
4093: Subroutine B<REAPER>:
4094: This is only invoked for the B<lond> parent I<PID>.
4095: Information pertaining to the child is removed.
4096: The socket port is cleaned up.
4097:
4098: =back
4099:
4100: B<SERVER-SIDE ACTIVITIES>
4101:
4102: Server-side information can be accepted in an encrypted or non-encrypted
4103: method.
4104:
4105: =over 4
4106:
4107: =item ping
4108:
4109: Query a client in the hosts.tab table; "Are you there?"
4110:
4111: =item pong
4112:
4113: Respond to a ping query.
4114:
4115: =item ekey
4116:
4117: Read in encrypted key, make cipher. Respond with a buildkey.
4118:
4119: =item load
4120:
4121: Respond with CPU load based on a computation upon /proc/loadavg.
4122:
4123: =item currentauth
4124:
4125: Reply with current authentication information (only over an
4126: encrypted channel).
4127:
4128: =item auth
4129:
4130: Only over an encrypted channel, reply as to whether a user's
4131: authentication information can be validated.
4132:
4133: =item passwd
4134:
4135: Allow for a password to be set.
4136:
4137: =item makeuser
4138:
4139: Make a user.
4140:
4141: =item passwd
4142:
4143: Allow for authentication mechanism and password to be changed.
4144:
4145: =item home
1.61 harris41 4146:
1.74 harris41 4147: Respond to a question "are you the home for a given user?"
4148:
4149: =item update
4150:
4151: Update contents of a subscribed resource.
4152:
4153: =item unsubscribe
4154:
4155: The server is unsubscribing from a resource.
4156:
4157: =item subscribe
4158:
4159: The server is subscribing to a resource.
4160:
4161: =item log
4162:
4163: Place in B<logs/lond.log>
4164:
4165: =item put
4166:
4167: stores hash in namespace
4168:
4169: =item rolesput
4170:
4171: put a role into a user's environment
4172:
4173: =item get
4174:
4175: returns hash with keys from array
4176: reference filled in from namespace
4177:
4178: =item eget
4179:
4180: returns hash with keys from array
4181: reference filled in from namesp (encrypts the return communication)
4182:
4183: =item rolesget
4184:
4185: get a role from a user's environment
4186:
4187: =item del
4188:
4189: deletes keys out of array from namespace
4190:
4191: =item keys
4192:
4193: returns namespace keys
4194:
4195: =item dump
4196:
4197: dumps the complete (or key matching regexp) namespace into a hash
4198:
4199: =item store
4200:
4201: stores hash permanently
4202: for this url; hashref needs to be given and should be a \%hashname; the
4203: remaining args aren't required and if they aren't passed or are '' they will
4204: be derived from the ENV
4205:
4206: =item restore
4207:
4208: returns a hash for a given url
4209:
4210: =item querysend
4211:
4212: Tells client about the lonsql process that has been launched in response
4213: to a sent query.
4214:
4215: =item queryreply
4216:
4217: Accept information from lonsql and make appropriate storage in temporary
4218: file space.
4219:
4220: =item idput
4221:
4222: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
4223: for each student, defined perhaps by the institutional Registrar.)
4224:
4225: =item idget
4226:
4227: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
4228: for each student, defined perhaps by the institutional Registrar.)
4229:
4230: =item tmpput
4231:
4232: Accept and store information in temporary space.
4233:
4234: =item tmpget
4235:
4236: Send along temporarily stored information.
4237:
4238: =item ls
4239:
4240: List part of a user's directory.
4241:
1.135 foxr 4242: =item pushtable
4243:
4244: Pushes a file in /home/httpd/lonTab directory. Currently limited to:
4245: hosts.tab and domain.tab. The old file is copied to *.tab.backup but
4246: must be restored manually in case of a problem with the new table file.
4247: pushtable requires that the request be encrypted and validated via
4248: ValidateManager. The form of the command is:
4249: enc:pushtable tablename <tablecontents> \n
4250: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
4251: cleartext newline.
4252:
1.74 harris41 4253: =item Hanging up (exit or init)
4254:
4255: What to do when a client tells the server that they (the client)
4256: are leaving the network.
4257:
4258: =item unknown command
4259:
4260: If B<lond> is sent an unknown command (not in the list above),
4261: it replys to the client "unknown_cmd".
1.135 foxr 4262:
1.74 harris41 4263:
4264: =item UNKNOWN CLIENT
4265:
4266: If the anti-spoofing algorithm cannot verify the client,
4267: the client is rejected (with a "refused" message sent
4268: to the client, and the connection is closed.
4269:
4270: =back
1.61 harris41 4271:
4272: =head1 PREREQUISITES
4273:
4274: IO::Socket
4275: IO::File
4276: Apache::File
4277: Symbol
4278: POSIX
4279: Crypt::IDEA
4280: LWP::UserAgent()
4281: GDBM_File
4282: Authen::Krb4
1.91 albertel 4283: Authen::Krb5
1.61 harris41 4284:
4285: =head1 COREQUISITES
4286:
4287: =head1 OSNAMES
4288:
4289: linux
4290:
4291: =head1 SCRIPT CATEGORIES
4292:
4293: Server/Process
4294:
4295: =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