Annotation of loncom/lond, revision 1.147
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 www 4: #
1.147 ! foxr 5: # $Id: lond,v 1.146 2003/09/16 10:28:14 foxr Exp $
1.60 www 6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
13: # the Free Software Foundation; either version 2 of the License, or
14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
27: # http://www.lon-capa.org/
28: #
1.1 albertel 29: # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,
1.2 www 30: # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,
1.6 www 31: # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
1.11 www 32: # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
1.12 harris41 33: # 03/07,05/31 Gerd Kortemeyer
1.20 www 34: # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
1.34 www 35: # 12/05,12/13,12/29 Gerd Kortemeyer
1.61 harris41 36: # YEAR=2001
1.36 www 37: # 02/12 Gerd Kortemeyer
1.41 www 38: # 03/24 Gerd Kortemeyer
1.51 www 39: # 05/11,05/28,08/30 Gerd Kortemeyer
1.59 www 40: # 11/26,11/27 Gerd Kortemeyer
1.62 www 41: # 12/22 Gerd Kortemeyer
1.63 www 42: # YEAR=2002
1.65 www 43: # 01/20/02,02/05 Gerd Kortemeyer
1.71 www 44: # 02/05 Guy Albertelli
45: # 02/12 Gerd Kortemeyer
1.73 www 46: # 02/19 Matthew Hall
47: # 02/25 Gerd Kortemeyer
1.106 foxr 48: # 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon
49: # logic simpler (and there were problems maintaining the preforked
50: # population). Since the time averaged connection rate is close to zero
51: # because lonc's purpose is to maintain near continuous connnections,
52: # preforking is not really needed.
1.135 foxr 53: # 08/xx/2003 Ron Fox: Add management requests. Management requests
54: # will be validated via a call to ValidateManager. At present, this
55: # is done by simple host verification. In the future we can modify
56: # this function to do a certificate check.
57: # Management functions supported include:
58: # - pushing /home/httpd/lonTabs/hosts.tab
59: # - pushing /home/httpd/lonTabs/domain.tab
1.141 foxr 60: # 09/08/2003 Ron Fox: Told lond to take care of change logging so we
61: # don't have to remember it:
1.142 www 62: # $Log: lond,v $
1.147 ! foxr 63: # Revision 1.146 2003/09/16 10:28:14 foxr
! 64: # ReinitProcess - decode the process selector and produce the associated pid
! 65: # filename. Note: While it is possible to test that valid process selectors are
! 66: # handled properly I am not able to test that invalid process selectors produce
! 67: # the appropriate error as lonManage also blocks the use of invalid process selectors.
! 68: #
1.146 foxr 69: # Revision 1.145 2003/09/16 10:13:20 foxr
70: # Added ReinitProcess function to oversee the parsing and processing of the
71: # reinit:<process> client request.
72: #
1.145 foxr 73: # Revision 1.144 2003/09/16 09:47:01 foxr
74: # Added skeletal support for SIGUSR2 (update hosts.tab)
75: #
1.144 foxr 76: # Revision 1.143 2003/09/15 10:03:52 foxr
77: # Completed and tested code for pushfile.
78: #
1.143 foxr 79: # Revision 1.142 2003/09/09 20:47:46 www
80: # Permanently store chatroom entries in chatroom.log
81: #
1.142 www 82: # Revision 1.141 2003/09/08 10:32:07 foxr
83: # Added PushFile sub This sub oversees the push of a new configuration table file
84: # Currently supported files are:
85: # - hosts.tab (transaction pushfile:hosts:contents)
86: # - domain.tab (transaction pushfile:domain:contents)
87: #
1.141 foxr 88:
1.54 harris41 89:
1.134 albertel 90: use strict;
1.80 harris41 91: use lib '/home/httpd/lib/perl/';
92: use LONCAPA::Configuration;
93:
1.1 albertel 94: use IO::Socket;
95: use IO::File;
1.126 albertel 96: #use Apache::File;
1.1 albertel 97: use Symbol;
98: use POSIX;
99: use Crypt::IDEA;
100: use LWP::UserAgent();
1.3 www 101: use GDBM_File;
102: use Authen::Krb4;
1.91 albertel 103: use Authen::Krb5;
1.49 albertel 104: use lib '/home/httpd/lib/perl/';
105: use localauth;
1.143 foxr 106: use File::Copy;
1.1 albertel 107:
1.77 foxr 108: my $DEBUG = 0; # Non zero to enable debug log entries.
109:
1.57 www 110: my $status='';
111: my $lastlog='';
112:
1.147 ! foxr 113: my $VERSION='$Revision: 1.146 $'; #' stupid emacs
1.121 albertel 114: my $remoteVERSION;
1.115 albertel 115: my $currenthostid;
116: my $currentdomainid;
1.134 albertel 117:
118: my $client;
1.140 foxr 119: my $clientip;
120:
1.134 albertel 121: my $server;
122: my $thisserver;
123:
124: my %hostid;
125: my %hostdom;
126: my %hostip;
1.141 foxr 127: my %perlvar; # Will have the apache conf defined perl vars.
1.134 albertel 128:
1.96 foxr 129: #
130: # The array below are password error strings."
131: #
1.97 foxr 132: my $lastpwderror = 13; # Largest error number from lcpasswd.
1.96 foxr 133: my @passwderrors = ("ok",
134: "lcpasswd must be run as user 'www'",
135: "lcpasswd got incorrect number of arguments",
136: "lcpasswd did not get the right nubmer of input text lines",
137: "lcpasswd too many simultaneous pwd changes in progress",
138: "lcpasswd User does not exist.",
139: "lcpasswd Incorrect current passwd",
140: "lcpasswd Unable to su to root.",
141: "lcpasswd Cannot set new passwd.",
142: "lcpasswd Username has invalid characters",
1.97 foxr 143: "lcpasswd Invalid characters in password",
144: "11", "12",
145: "lcpasswd Password mismatch");
146:
147:
148: # The array below are lcuseradd error strings.:
149:
150: my $lastadderror = 13;
151: my @adderrors = ("ok",
152: "User ID mismatch, lcuseradd must run as user www",
153: "lcuseradd Incorrect number of command line parameters must be 3",
154: "lcuseradd Incorrect number of stdinput lines, must be 3",
155: "lcuseradd Too many other simultaneous pwd changes in progress",
156: "lcuseradd User does not exist",
157: "lcuseradd Unabel to mak ewww member of users's group",
158: "lcuseradd Unable to su to root",
159: "lcuseradd Unable to set password",
160: "lcuseradd Usrname has invbalid charcters",
161: "lcuseradd Password has an invalid character",
162: "lcuseradd User already exists",
163: "lcuseradd Could not add user.",
164: "lcuseradd Password mismatch");
165:
1.96 foxr 166:
167: #
1.140 foxr 168: # GetCertificate: Given a transaction that requires a certificate,
169: # this function will extract the certificate from the transaction
170: # request. Note that at this point, the only concept of a certificate
171: # is the hostname to which we are connected.
172: #
173: # Parameter:
174: # request - The request sent by our client (this parameterization may
175: # need to change when we really use a certificate granting
176: # authority.
177: #
178: sub GetCertificate {
179: my $request = shift;
180:
181: return $clientip;
182: }
183:
184:
185: #
186: # ValidManager: Determines if a given certificate represents a valid manager.
187: # in this primitive implementation, the 'certificate' is
188: # just the connecting loncapa client name. This is checked
189: # against a valid client list in the configuration.
190: #
191: #
192: sub ValidManager {
193: my $certificate = shift;
194:
195: my $hostentry = $hostid{$certificate};
196: if ($hostentry ne undef) {
197: &logthis('<font color="yellow">Authenticating manager'.
198: " $hostentry</font>");
199: return 1;
200: } else {
201: &logthis('<font color="red"> Failed manager authentication '.
202: "$certificate </font>");
203: }
204: }
205: #
1.143 foxr 206: # CopyFile: Called as part of the process of installing a
207: # new configuration file. This function copies an existing
208: # file to a backup file.
209: # Parameters:
210: # oldfile - Name of the file to backup.
211: # newfile - Name of the backup file.
212: # Return:
213: # 0 - Failure (errno has failure reason).
214: # 1 - Success.
215: #
216: sub CopyFile {
217: my $oldfile = shift;
218: my $newfile = shift;
219:
220: # The file must exist:
221:
222: if(-e $oldfile) {
223:
224: # Read the old file.
225:
226: my $oldfh = IO::File->new("< $oldfile");
227: if(!$oldfh) {
228: return 0;
229: }
230: my @contents = <$oldfh>; # Suck in the entire file.
231:
232: # write the backup file:
233:
234: my $newfh = IO::File->new("> $newfile");
235: if(!(defined $newfh)){
236: return 0;
237: }
238: my $lines = scalar @contents;
239: for (my $i =0; $i < $lines; $i++) {
240: print $newfh ($contents[$i]);
241: }
242:
243: $oldfh->close;
244: $newfh->close;
245:
246: chmod(0660, $newfile);
247:
248: return 1;
249:
250: } else {
251: return 0;
252: }
253: }
254:
255: #
256: # InstallFile: Called to install an administrative file:
257: # - The file is created with <name>.tmp
258: # - The <name>.tmp file is then mv'd to <name>
259: # This lugubrious procedure is done to ensure that we are never without
260: # a valid, even if dated, version of the file regardless of who crashes
261: # and when the crash occurs.
262: #
263: # Parameters:
264: # Name of the file
265: # File Contents.
266: # Return:
267: # nonzero - success.
268: # 0 - failure and $! has an errno.
269: #
270: sub InstallFile {
271: my $Filename = shift;
272: my $Contents = shift;
273: my $TempFile = $Filename.".tmp";
274:
275: # Open the file for write:
276:
277: my $fh = IO::File->new("> $TempFile"); # Write to temp.
278: if(!(defined $fh)) {
279: &logthis('<font color="red"> Unable to create '.$TempFile."</font>");
280: return 0;
281: }
282: # write the contents of the file:
283:
284: print $fh ($Contents);
285: $fh->close; # In case we ever have a filesystem w. locking
286:
287: chmod(0660, $TempFile);
288:
289: # Now we can move install the file in position.
290:
291: move($TempFile, $Filename);
292:
293: return 1;
294: }
295:
296: #
1.141 foxr 297: # PushFile: Called to do an administrative push of a file.
298: # - Ensure the file being pushed is one we support.
299: # - Backup the old file to <filename.saved>
300: # - Separate the contents of the new file out from the
301: # rest of the request.
302: # - Write the new file.
303: # Parameter:
304: # Request - The entire user request. This consists of a : separated
305: # string pushfile:tablename:contents.
306: # NOTE: The contents may have :'s in it as well making things a bit
307: # more interesting... but not much.
308: # Returns:
309: # String to send to client ("ok" or "refused" if bad file).
310: #
311: sub PushFile {
312: my $request = shift;
313: my ($command, $filename, $contents) = split(":", $request, 3);
314:
315: # At this point in time, pushes for only the following tables are
316: # supported:
317: # hosts.tab ($filename eq host).
318: # domain.tab ($filename eq domain).
319: # Construct the destination filename or reject the request.
320: #
321: # lonManage is supposed to ensure this, however this session could be
322: # part of some elaborate spoof that managed somehow to authenticate.
323: #
324:
325: my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir.
326: if ($filename eq "host") {
327: $tablefile .= "hosts.tab";
328: } elsif ($filename eq "domain") {
329: $tablefile .= "domain.tab";
330: } else {
331: return "refused";
332: }
333: #
334: # >copy< the old table to the backup table
335: # don't rename in case system crashes/reboots etc. in the time
336: # window between a rename and write.
337: #
338: my $backupfile = $tablefile;
339: $backupfile =~ s/\.tab$/.old/;
1.143 foxr 340: if(!CopyFile($tablefile, $backupfile)) {
341: &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
342: return "error:$!";
343: }
1.141 foxr 344: &logthis('<font color="green"> Pushfile: backed up '
345: .$tablefile." to $backupfile</font>");
346:
347: # Install the new file:
348:
1.143 foxr 349: if(!InstallFile($tablefile, $contents)) {
350: &logthis('<font color="red"> Pushfile: unable to install '
1.145 foxr 351: .$tablefile." $! </font>");
1.143 foxr 352: return "error:$!";
353: }
354: else {
355: &logthis('<font color="green"> Installed new '.$tablefile
356: ."</font>");
357:
358: }
359:
1.141 foxr 360:
361: # Indicate success:
362:
363: return "ok";
364:
365: }
1.145 foxr 366:
367: #
368: # Called to re-init either lonc or lond.
369: #
370: # Parameters:
371: # request - The full request by the client. This is of the form
372: # reinit:<process>
373: # where <process> is allowed to be either of
374: # lonc or lond
375: #
376: # Returns:
377: # The string to be sent back to the client either:
378: # ok - Everything worked just fine.
379: # error:why - There was a failure and why describes the reason.
380: #
381: #
382: sub ReinitProcess {
383: my $request = shift;
384:
1.146 foxr 385:
386: # separate the request (reinit) from the process identifier and
387: # validate it producing the name of the .pid file for the process.
388: #
389: #
390: my ($junk, $process) = split(":", $request);
1.147 ! foxr 391: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
1.146 foxr 392: if($process eq 'lonc') {
393: $processpidfile = $processpidfile."lonc.pid";
1.147 ! foxr 394: if (!open(PIDFILE, "< $processpidfile")) {
! 395: return "error:Open failed for $processpidfile";
! 396: }
! 397: my $loncpid = <PIDFILE>;
! 398: close(PIDFILE);
! 399: logthis('<font color="red"> Reinitializing lonc pid='.$loncpid
! 400: ."</font>");
! 401: kill("USR2", $loncpid);
1.146 foxr 402: } elsif ($process eq 'lond') {
1.147 ! foxr 403: logthis('<font color="red"> Reinitializing self (lond) </font>');
! 404: &UpdateHosts; # Lond is us!!
1.146 foxr 405: } else {
406: &logthis('<font color="yellow" Invalid reinit request for '.$process
407: ."</font>");
408: return "error:Invalid process identifier $process";
409: }
1.145 foxr 410: return 'ok';
411: }
412:
1.141 foxr 413: #
1.96 foxr 414: # Convert an error return code from lcpasswd to a string value.
415: #
416: sub lcpasswdstrerror {
417: my $ErrorCode = shift;
1.97 foxr 418: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
1.96 foxr 419: return "lcpasswd Unrecognized error return value ".$ErrorCode;
420: } else {
1.98 foxr 421: return $passwderrors[$ErrorCode];
1.96 foxr 422: }
423: }
424:
1.97 foxr 425: #
426: # Convert an error return code from lcuseradd to a string value:
427: #
428: sub lcuseraddstrerror {
429: my $ErrorCode = shift;
430: if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
431: return "lcuseradd - Unrecognized error code: ".$ErrorCode;
432: } else {
1.98 foxr 433: return $adderrors[$ErrorCode];
1.97 foxr 434: }
435: }
436:
1.23 harris41 437: # grabs exception and records it to log before exiting
438: sub catchexception {
1.27 albertel 439: my ($error)=@_;
1.25 www 440: $SIG{'QUIT'}='DEFAULT';
441: $SIG{__DIE__}='DEFAULT';
1.23 harris41 442: &logthis("<font color=red>CRITICAL: "
1.134 albertel 443: ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
1.27 albertel 444: ."a crash with this error msg->[$error]</font>");
1.57 www 445: &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27 albertel 446: if ($client) { print $client "error: $error\n"; }
1.59 www 447: $server->close();
1.27 albertel 448: die($error);
1.23 harris41 449: }
450:
1.63 www 451: sub timeout {
452: &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
453: &catchexception('Timeout');
454: }
1.22 harris41 455: # -------------------------------- Set signal handlers to record abnormal exits
456:
457: $SIG{'QUIT'}=\&catchexception;
458: $SIG{__DIE__}=\&catchexception;
459:
1.81 matthew 460: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
1.95 harris41 461: &status("Read loncapa.conf and loncapa_apache.conf");
462: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.141 foxr 463: %perlvar=%{$perlvarref};
1.80 harris41 464: undef $perlvarref;
1.19 www 465:
1.35 harris41 466: # ----------------------------- Make sure this process is running from user=www
467: my $wwwid=getpwnam('www');
468: if ($wwwid!=$<) {
1.134 albertel 469: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
470: my $subj="LON: $currenthostid User ID mismatch";
1.37 harris41 471: system("echo 'User ID mismatch. lond must be run as user www.' |\
1.35 harris41 472: mailto $emailto -s '$subj' > /dev/null");
473: exit 1;
474: }
475:
1.19 www 476: # --------------------------------------------- Check if other instance running
477:
478: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
479:
480: if (-e $pidfile) {
481: my $lfh=IO::File->new("$pidfile");
482: my $pide=<$lfh>;
483: chomp($pide);
1.29 harris41 484: if (kill 0 => $pide) { die "already running"; }
1.19 www 485: }
1.1 albertel 486:
487: # ------------------------------------------------------------- Read hosts file
488:
1.29 harris41 489: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
1.1 albertel 490:
1.134 albertel 491: while (my $configline=<CONFIG>) {
1.1 albertel 492: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
1.70 harris41 493: chomp($ip); $ip=~s/\D+$//;
1.1 albertel 494: $hostid{$ip}=$id;
1.115 albertel 495: $hostdom{$id}=$domain;
496: $hostip{$id}=$ip;
1.116 albertel 497: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
1.1 albertel 498: }
499: close(CONFIG);
500:
501: # establish SERVER socket, bind and listen.
502: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
503: Type => SOCK_STREAM,
504: Proto => 'tcp',
505: Reuse => 1,
506: Listen => 10 )
1.29 harris41 507: or die "making socket: $@\n";
1.1 albertel 508:
509: # --------------------------------------------------------- Do global variables
510:
511: # global variables
512:
1.134 albertel 513: my %children = (); # keys are current child process IDs
514: my $children = 0; # current number of children
1.1 albertel 515:
516: sub REAPER { # takes care of dead children
517: $SIG{CHLD} = \&REAPER;
518: my $pid = wait;
1.67 albertel 519: if (defined($children{$pid})) {
520: &logthis("Child $pid died");
521: $children --;
522: delete $children{$pid};
523: } else {
524: &logthis("Unknown Child $pid died");
525: }
1.1 albertel 526: }
527:
528: sub HUNTSMAN { # signal handler for SIGINT
529: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
530: kill 'INT' => keys %children;
1.59 www 531: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1 albertel 532: my $execdir=$perlvar{'lonDaemons'};
533: unlink("$execdir/logs/lond.pid");
1.9 www 534: &logthis("<font color=red>CRITICAL: Shutting down</font>");
1.1 albertel 535: exit; # clean up with dignity
536: }
537:
538: sub HUPSMAN { # signal handler for SIGHUP
539: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
540: kill 'INT' => keys %children;
1.59 www 541: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.9 www 542: &logthis("<font color=red>CRITICAL: Restarting</font>");
1.134 albertel 543: my $execdir=$perlvar{'lonDaemons'};
1.30 harris41 544: unlink("$execdir/logs/lond.pid");
1.1 albertel 545: exec("$execdir/lond"); # here we go again
546: }
547:
1.144 foxr 548: #
549: # Called in response to a USR2 signal.
550: # - Reread hosts.tab
551: # - All children connected to hosts that were removed from hosts.tab
552: # are killed via SIGINT
553: # - All children connected to previously existing hosts are sent SIGUSR1
554: # - Our internal hosts hash is updated to reflect the new contents of
555: # hosts.tab causing connections from hosts added to hosts.tab to
556: # now be honored.
557: #
558: sub UpdateHosts {
1.147 ! foxr 559: logthis('<font color="blue"> Updating connections </font>');
1.144 foxr 560: }
561:
1.57 www 562: sub checkchildren {
563: &initnewstatus();
564: &logstatus();
565: &logthis('Going to check on the children');
1.134 albertel 566: my $docdir=$perlvar{'lonDocRoot'};
1.61 harris41 567: foreach (sort keys %children) {
1.57 www 568: sleep 1;
569: unless (kill 'USR1' => $_) {
570: &logthis ('Child '.$_.' is dead');
571: &logstatus($$.' is dead');
572: }
1.61 harris41 573: }
1.63 www 574: sleep 5;
1.113 albertel 575: $SIG{ALRM} = sub { die "timeout" };
576: $SIG{__DIE__} = 'DEFAULT';
1.63 www 577: foreach (sort keys %children) {
578: unless (-e "$docdir/lon-status/londchld/$_.txt") {
1.113 albertel 579: eval {
580: alarm(300);
1.63 www 581: &logthis('Child '.$_.' did not respond');
1.67 albertel 582: kill 9 => $_;
1.131 albertel 583: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
584: #$subj="LON: $currenthostid killed lond process $_";
585: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
586: #$execdir=$perlvar{'lonDaemons'};
587: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
1.113 albertel 588: alarm(0);
589: }
1.63 www 590: }
591: }
1.113 albertel 592: $SIG{ALRM} = 'DEFAULT';
593: $SIG{__DIE__} = \&cathcexception;
1.57 www 594: }
595:
1.1 albertel 596: # --------------------------------------------------------------------- Logging
597:
598: sub logthis {
599: my $message=shift;
600: my $execdir=$perlvar{'lonDaemons'};
601: my $fh=IO::File->new(">>$execdir/logs/lond.log");
602: my $now=time;
603: my $local=localtime($now);
1.58 www 604: $lastlog=$local.': '.$message;
1.1 albertel 605: print $fh "$local ($$): $message\n";
606: }
607:
1.77 foxr 608: # ------------------------- Conditional log if $DEBUG true.
609: sub Debug {
610: my $message = shift;
611: if($DEBUG) {
612: &logthis($message);
613: }
614: }
1.57 www 615: # ------------------------------------------------------------------ Log status
616:
617: sub logstatus {
618: my $docdir=$perlvar{'lonDocRoot'};
1.63 www 619: {
1.57 www 620: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
1.115 albertel 621: print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
1.63 www 622: $fh->close();
623: }
624: {
625: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
626: print $fh $status."\n".$lastlog."\n".time;
627: $fh->close();
628: }
1.57 www 629: }
630:
631: sub initnewstatus {
632: my $docdir=$perlvar{'lonDocRoot'};
633: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
634: my $now=time;
635: my $local=localtime($now);
636: print $fh "LOND status $local - parent $$\n\n";
1.64 www 637: opendir(DIR,"$docdir/lon-status/londchld");
1.134 albertel 638: while (my $filename=readdir(DIR)) {
1.64 www 639: unlink("$docdir/lon-status/londchld/$filename");
640: }
641: closedir(DIR);
1.57 www 642: }
643:
644: # -------------------------------------------------------------- Status setting
645:
646: sub status {
647: my $what=shift;
648: my $now=time;
649: my $local=localtime($now);
650: $status=$local.': '.$what;
1.103 www 651: $0='lond: '.$what.' '.$local;
1.57 www 652: }
1.11 www 653:
654: # -------------------------------------------------------- Escape Special Chars
655:
656: sub escape {
657: my $str=shift;
658: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
659: return $str;
660: }
661:
662: # ----------------------------------------------------- Un-Escape Special Chars
663:
664: sub unescape {
665: my $str=shift;
666: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
667: return $str;
668: }
669:
1.1 albertel 670: # ----------------------------------------------------------- Send USR1 to lonc
671:
672: sub reconlonc {
673: my $peerfile=shift;
674: &logthis("Trying to reconnect for $peerfile");
675: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
676: if (my $fh=IO::File->new("$loncfile")) {
677: my $loncpid=<$fh>;
678: chomp($loncpid);
679: if (kill 0 => $loncpid) {
680: &logthis("lonc at pid $loncpid responding, sending USR1");
681: kill USR1 => $loncpid;
682: } else {
1.9 www 683: &logthis(
684: "<font color=red>CRITICAL: "
685: ."lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 686: }
687: } else {
1.9 www 688: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
1.1 albertel 689: }
690: }
691:
692: # -------------------------------------------------- Non-critical communication
1.11 www 693:
1.1 albertel 694: sub subreply {
695: my ($cmd,$server)=@_;
696: my $peerfile="$perlvar{'lonSockDir'}/$server";
697: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
698: Type => SOCK_STREAM,
699: Timeout => 10)
700: or return "con_lost";
701: print $sclient "$cmd\n";
702: my $answer=<$sclient>;
703: chomp($answer);
704: if (!$answer) { $answer="con_lost"; }
705: return $answer;
706: }
707:
708: sub reply {
709: my ($cmd,$server)=@_;
710: my $answer;
1.115 albertel 711: if ($server ne $currenthostid) {
1.1 albertel 712: $answer=subreply($cmd,$server);
713: if ($answer eq 'con_lost') {
714: $answer=subreply("ping",$server);
715: if ($answer ne $server) {
1.115 albertel 716: &logthis("sub reply: answer != server answer is $answer, server is $server");
1.1 albertel 717: &reconlonc("$perlvar{'lonSockDir'}/$server");
718: }
719: $answer=subreply($cmd,$server);
720: }
721: } else {
722: $answer='self_reply';
723: }
724: return $answer;
725: }
726:
1.13 www 727: # -------------------------------------------------------------- Talk to lonsql
728:
1.12 harris41 729: sub sqlreply {
730: my ($cmd)=@_;
731: my $answer=subsqlreply($cmd);
732: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
733: return $answer;
734: }
735:
736: sub subsqlreply {
737: my ($cmd)=@_;
738: my $unixsock="mysqlsock";
739: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
740: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
741: Type => SOCK_STREAM,
742: Timeout => 10)
743: or return "con_lost";
744: print $sclient "$cmd\n";
745: my $answer=<$sclient>;
746: chomp($answer);
747: if (!$answer) { $answer="con_lost"; }
748: return $answer;
749: }
750:
1.1 albertel 751: # -------------------------------------------- Return path to profile directory
1.11 www 752:
1.1 albertel 753: sub propath {
754: my ($udom,$uname)=@_;
755: $udom=~s/\W//g;
756: $uname=~s/\W//g;
1.16 www 757: my $subdir=$uname.'__';
1.1 albertel 758: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
759: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
760: return $proname;
761: }
762:
763: # --------------------------------------- Is this the home server of an author?
1.11 www 764:
1.1 albertel 765: sub ishome {
766: my $author=shift;
767: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
768: my ($udom,$uname)=split(/\//,$author);
769: my $proname=propath($udom,$uname);
770: if (-e $proname) {
771: return 'owner';
772: } else {
773: return 'not_owner';
774: }
775: }
776:
777: # ======================================================= Continue main program
778: # ---------------------------------------------------- Fork once and dissociate
779:
1.134 albertel 780: my $fpid=fork;
1.1 albertel 781: exit if $fpid;
1.29 harris41 782: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 783:
1.29 harris41 784: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 785:
786: # ------------------------------------------------------- Write our PID on disk
787:
1.134 albertel 788: my $execdir=$perlvar{'lonDaemons'};
1.1 albertel 789: open (PIDSAVE,">$execdir/logs/lond.pid");
790: print PIDSAVE "$$\n";
791: close(PIDSAVE);
1.9 www 792: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
1.57 www 793: &status('Starting');
1.1 albertel 794:
1.106 foxr 795:
1.1 albertel 796:
797: # ----------------------------------------------------- Install signal handlers
798:
1.57 www 799:
1.1 albertel 800: $SIG{CHLD} = \&REAPER;
801: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
802: $SIG{HUP} = \&HUPSMAN;
1.57 www 803: $SIG{USR1} = \&checkchildren;
1.144 foxr 804: $SIG{USR2} = \&UpdateHosts;
1.106 foxr 805:
806:
807: # --------------------------------------------------------------
808: # Accept connections. When a connection comes in, it is validated
809: # and if good, a child process is created to process transactions
810: # along the connection.
811:
1.1 albertel 812: while (1) {
1.106 foxr 813: $client = $server->accept() or next;
814: make_new_child($client);
1.1 albertel 815: }
816:
817: sub make_new_child {
818: my $pid;
819: my $cipher;
820: my $sigset;
1.106 foxr 821:
822: $client = shift;
1.1 albertel 823: &logthis("Attempting to start child");
824: # block signal for fork
825: $sigset = POSIX::SigSet->new(SIGINT);
826: sigprocmask(SIG_BLOCK, $sigset)
1.29 harris41 827: or die "Can't block SIGINT for fork: $!\n";
1.134 albertel 828:
1.29 harris41 829: die "fork: $!" unless defined ($pid = fork);
1.1 albertel 830:
831: if ($pid) {
832: # Parent records the child's birth and returns.
833: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 834: or die "Can't unblock SIGINT for fork: $!\n";
1.1 albertel 835: $children{$pid} = 1;
836: $children++;
1.57 www 837: &status('Started child '.$pid);
1.1 albertel 838: return;
839: } else {
840: # Child can *not* return from this subroutine.
841: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
1.126 albertel 842: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
843: #don't get intercepted
1.57 www 844: $SIG{USR1}= \&logstatus;
1.63 www 845: $SIG{ALRM}= \&timeout;
1.57 www 846: $lastlog='Forked ';
847: $status='Forked';
848:
1.1 albertel 849: # unblock signals
850: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 851: or die "Can't unblock SIGINT for fork: $!\n";
1.13 www 852:
1.134 albertel 853: my $tmpsnum=0;
1.91 albertel 854: #---------------------------------------------------- kerberos 5 initialization
855: &Authen::Krb5::init_context();
856: &Authen::Krb5::init_ets();
857:
1.57 www 858: &status('Accepted connection');
1.1 albertel 859: # =============================================================================
860: # do something with the connection
861: # -----------------------------------------------------------------------------
1.94 albertel 862: $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
863: # connection liveness.
1.2 www 864: # see if we know client and check for spoof IP by challenge
1.106 foxr 865: my $caller = getpeername($client);
1.1 albertel 866: my ($port,$iaddr)=unpack_sockaddr_in($caller);
1.134 albertel 867: $clientip=inet_ntoa($iaddr);
1.1 albertel 868: my $clientrec=($hostid{$clientip} ne undef);
1.9 www 869: &logthis(
1.115 albertel 870: "<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
1.51 www 871: );
1.57 www 872: &status("Connecting $clientip ($hostid{$clientip})");
1.2 www 873: my $clientok;
1.1 albertel 874: if ($clientrec) {
1.57 www 875: &status("Waiting for init from $clientip ($hostid{$clientip})");
1.2 www 876: my $remotereq=<$client>;
1.115 albertel 877: $remotereq=~s/[^\w:]//g;
878: if ($remotereq =~ /^init/) {
1.121 albertel 879: &sethost("sethost:$perlvar{'lonHostID'}");
1.2 www 880: my $challenge="$$".time;
881: print $client "$challenge\n";
1.57 www 882: &status(
883: "Waiting for challenge reply from $clientip ($hostid{$clientip})");
1.2 www 884: $remotereq=<$client>;
885: $remotereq=~s/\W//g;
886: if ($challenge eq $remotereq) {
887: $clientok=1;
888: print $client "ok\n";
889: } else {
1.9 www 890: &logthis(
891: "<font color=blue>WARNING: $clientip did not reply challenge</font>");
1.57 www 892: &status('No challenge reply '.$clientip);
1.2 www 893: }
894: } else {
1.9 www 895: &logthis(
896: "<font color=blue>WARNING: "
897: ."$clientip failed to initialize: >$remotereq< </font>");
1.57 www 898: &status('No init '.$clientip);
1.2 www 899: }
900: } else {
1.9 www 901: &logthis(
902: "<font color=blue>WARNING: Unknown client $clientip</font>");
1.57 www 903: &status('Hung up on '.$clientip);
1.2 www 904: }
905: if ($clientok) {
1.1 albertel 906: # ---------------- New known client connecting, could mean machine online again
1.75 foxr 907:
1.115 albertel 908: foreach my $id (keys(%hostip)) {
909: if ($hostip{$id} ne $clientip ||
910: $hostip{$currenthostid} eq $clientip) {
911: # no need to try to do recon's to myself
912: next;
913: }
914: &reconlonc("$perlvar{'lonSockDir'}/$id");
915: }
916: &logthis("<font color=green>Established connection: $hostid{$clientip}</font>");
1.58 www 917: &status('Will listen to '.$hostid{$clientip});
1.1 albertel 918: # ------------------------------------------------------------ Process requests
919: while (my $userinput=<$client>) {
920: chomp($userinput);
1.79 foxr 921: Debug("Request = $userinput\n");
1.57 www 922: &status('Processing '.$hostid{$clientip}.': '.$userinput);
1.1 albertel 923: my $wasenc=0;
1.63 www 924: alarm(120);
1.1 albertel 925: # ------------------------------------------------------------ See if encrypted
926: if ($userinput =~ /^enc/) {
927: if ($cipher) {
928: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
929: $userinput='';
930: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
931: $userinput.=
932: $cipher->decrypt(
933: pack("H16",substr($encinput,$encidx,16))
934: );
935: }
936: $userinput=substr($userinput,0,$cmdlength);
937: $wasenc=1;
938: }
1.75 foxr 939: }
940:
1.1 albertel 941: # ------------------------------------------------------------- Normal commands
942: # ------------------------------------------------------------------------ ping
943: if ($userinput =~ /^ping/) {
1.115 albertel 944: print $client "$currenthostid\n";
1.1 albertel 945: # ------------------------------------------------------------------------ pong
1.137 foxr 946: }elsif ($userinput =~ /^pong/) {
1.134 albertel 947: my $reply=&reply("ping",$hostid{$clientip});
1.115 albertel 948: print $client "$currenthostid:$reply\n";
1.1 albertel 949: # ------------------------------------------------------------------------ ekey
950: } elsif ($userinput =~ /^ekey/) {
951: my $buildkey=time.$$.int(rand 100000);
952: $buildkey=~tr/1-6/A-F/;
953: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
1.115 albertel 954: my $key=$currenthostid.$hostid{$clientip};
1.1 albertel 955: $key=~tr/a-z/A-Z/;
956: $key=~tr/G-P/0-9/;
957: $key=~tr/Q-Z/0-9/;
958: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
959: $key=substr($key,0,32);
960: my $cipherkey=pack("H32",$key);
961: $cipher=new IDEA $cipherkey;
962: print $client "$buildkey\n";
963: # ------------------------------------------------------------------------ load
964: } elsif ($userinput =~ /^load/) {
965: my $loadavg;
966: {
967: my $loadfile=IO::File->new('/proc/loadavg');
968: $loadavg=<$loadfile>;
969: }
970: $loadavg =~ s/\s.*//g;
1.127 albertel 971: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
1.1 albertel 972: print $client "$loadpercent\n";
1.127 albertel 973: # -------------------------------------------------------------------- userload
974: } elsif ($userinput =~ /^userload/) {
975: my $userloadpercent=&userload();
976: print $client "$userloadpercent\n";
1.137 foxr 977:
978: #
979: # Transactions requiring encryption:
980: #
1.54 harris41 981: # ----------------------------------------------------------------- currentauth
982: } elsif ($userinput =~ /^currentauth/) {
983: if ($wasenc==1) {
984: my ($cmd,$udom,$uname)=split(/:/,$userinput);
1.79 foxr 985: my $result = GetAuthType($udom, $uname);
1.78 foxr 986: if($result eq "nouser") {
987: print $client "unknown_user\n";
988: }
989: else {
990: print $client "$result\n"
991: }
1.54 harris41 992: } else {
993: print $client "refused\n";
994: }
1.137 foxr 995: #--------------------------------------------------------------------- pushfile
996: } elsif($userinput =~ /^pushfile/) {
1.140 foxr 997: if($wasenc == 1) {
998: my $cert = GetCertificate($userinput);
999: if(ValidManager($cert)) {
1.141 foxr 1000: my $reply = PushFile($userinput);
1001: print $client "$reply\n";
1.140 foxr 1002: } else {
1003: print $client "refused\n";
1004: }
1005: } else {
1006: print $client "refused\n";
1007: }
1.137 foxr 1008: #--------------------------------------------------------------------- reinit
1009: } elsif($userinput =~ /^reinit/) {
1.140 foxr 1010: if ($wasenc == 1) {
1011: my $cert = GetCertificate($userinput);
1012: if(ValidManager($cert)) {
1.146 foxr 1013: chomp($userinput);
1.145 foxr 1014: my $reply = ReinitProcess($userinput);
1015: print $client "$reply\n";
1.140 foxr 1016: } else {
1017: print $client "refused\n";
1018: }
1019: } else {
1020: print $client "refused\n";
1021: }
1.1 albertel 1022: # ------------------------------------------------------------------------ auth
1023: } elsif ($userinput =~ /^auth/) {
1024: if ($wasenc==1) {
1025: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
1026: chomp($upass);
1.11 www 1027: $upass=unescape($upass);
1.1 albertel 1028: my $proname=propath($udom,$uname);
1029: my $passfilename="$proname/passwd";
1030: if (-e $passfilename) {
1031: my $pf = IO::File->new($passfilename);
1032: my $realpasswd=<$pf>;
1033: chomp($realpasswd);
1.2 www 1034: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
1035: my $pwdcorrect=0;
1036: if ($howpwd eq 'internal') {
1.99 foxr 1037: &Debug("Internal auth");
1.2 www 1038: $pwdcorrect=
1039: (crypt($upass,$contentpwd) eq $contentpwd);
1040: } elsif ($howpwd eq 'unix') {
1.99 foxr 1041: &Debug("Unix auth");
1042: if((getpwnam($uname))[1] eq "") { #no such user!
1043: $pwdcorrect = 0;
1044: } else {
1045: $contentpwd=(getpwnam($uname))[1];
1046: my $pwauth_path="/usr/local/sbin/pwauth";
1047: unless ($contentpwd eq 'x') {
1048: $pwdcorrect=
1049: (crypt($upass,$contentpwd) eq
1050: $contentpwd);
1051: }
1052:
1.52 harris41 1053: elsif (-e $pwauth_path) {
1054: open PWAUTH, "|$pwauth_path" or
1055: die "Cannot invoke authentication";
1056: print PWAUTH "$uname\n$upass\n";
1057: close PWAUTH;
1058: $pwdcorrect=!$?;
1.99 foxr 1059: }
1.52 harris41 1060: }
1.3 www 1061: } elsif ($howpwd eq 'krb4') {
1.134 albertel 1062: my $null=pack("C",0);
1.104 matthew 1063: unless ($upass=~/$null/) {
1064: my $krb4_error = &Authen::Krb4::get_pw_in_tkt
1065: ($uname,"",$contentpwd,'krbtgt',
1066: $contentpwd,1,$upass);
1067: if (!$krb4_error) {
1068: $pwdcorrect = 1;
1069: } else {
1070: $pwdcorrect=0;
1071: # log error if it is not a bad password
1072: if ($krb4_error != 62) {
1073: &logthis('krb4:'.$uname.','.$contentpwd.','.
1074: &Authen::Krb4::get_err_txt($Authen::Krb4::error));
1075: }
1076: }
1077: }
1.91 albertel 1078: } elsif ($howpwd eq 'krb5') {
1.134 albertel 1079: my $null=pack("C",0);
1.91 albertel 1080: unless ($upass=~/$null/) {
1081: my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
1082: my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
1083: my $krbserver=&Authen::Krb5::parse_name($krbservice);
1084: my $credentials=&Authen::Krb5::cc_default();
1085: $credentials->initialize($krbclient);
1086: my $krbreturn =
1087: &Authen::Krb5::get_in_tkt_with_password(
1088: $krbclient,$krbserver,$upass,$credentials);
1.92 albertel 1089: # unless ($krbreturn) {
1090: # &logthis("Krb5 Error: ".
1091: # &Authen::Krb5::error());
1092: # }
1.91 albertel 1093: $pwdcorrect = ($krbreturn == 1);
1094: } else { $pwdcorrect=0; }
1.50 albertel 1095: } elsif ($howpwd eq 'localauth') {
1.49 albertel 1096: $pwdcorrect=&localauth::localauth($uname,$upass,
1097: $contentpwd);
1098: }
1.2 www 1099: if ($pwdcorrect) {
1.1 albertel 1100: print $client "authorized\n";
1101: } else {
1102: print $client "non_authorized\n";
1103: }
1104: } else {
1105: print $client "unknown_user\n";
1106: }
1107: } else {
1108: print $client "refused\n";
1109: }
1110: # ---------------------------------------------------------------------- passwd
1111: } elsif ($userinput =~ /^passwd/) {
1112: if ($wasenc==1) {
1113: my
1114: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
1115: chomp($npass);
1.32 www 1116: $upass=&unescape($upass);
1117: $npass=&unescape($npass);
1.98 foxr 1118: &Debug("Trying to change password for $uname");
1.72 matthew 1119: my $proname=propath($udom,$uname);
1.1 albertel 1120: my $passfilename="$proname/passwd";
1121: if (-e $passfilename) {
1122: my $realpasswd;
1123: { my $pf = IO::File->new($passfilename);
1124: $realpasswd=<$pf>; }
1125: chomp($realpasswd);
1.2 www 1126: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
1127: if ($howpwd eq 'internal') {
1.98 foxr 1128: &Debug("internal auth");
1.2 www 1129: if (crypt($upass,$contentpwd) eq $contentpwd) {
1130: my $salt=time;
1131: $salt=substr($salt,6,2);
1132: my $ncpass=crypt($npass,$salt);
1.139 albertel 1133: {
1134: my $pf;
1135: if ($pf = IO::File->new(">$passfilename")) {
1136: print $pf "internal:$ncpass\n";
1137: &logthis("Result of password change for $uname: pwchange_success");
1138: print $client "ok\n";
1139: } else {
1140: &logthis("Unable to open $uname passwd to change password");
1141: print $client "non_authorized\n";
1142: }
1143: }
1144:
1.2 www 1145: } else {
1146: print $client "non_authorized\n";
1147: }
1.72 matthew 1148: } elsif ($howpwd eq 'unix') {
1149: # Unix means we have to access /etc/password
1150: # one way or another.
1151: # First: Make sure the current password is
1152: # correct
1.98 foxr 1153: &Debug("auth is unix");
1.72 matthew 1154: $contentpwd=(getpwnam($uname))[1];
1155: my $pwdcorrect = "0";
1156: my $pwauth_path="/usr/local/sbin/pwauth";
1157: unless ($contentpwd eq 'x') {
1158: $pwdcorrect=
1159: (crypt($upass,$contentpwd) eq $contentpwd);
1160: } elsif (-e $pwauth_path) {
1161: open PWAUTH, "|$pwauth_path" or
1162: die "Cannot invoke authentication";
1163: print PWAUTH "$uname\n$upass\n";
1164: close PWAUTH;
1.98 foxr 1165: &Debug("exited pwauth with $? ($uname,$upass) ");
1166: $pwdcorrect=($? == 0);
1.72 matthew 1167: }
1168: if ($pwdcorrect) {
1169: my $execdir=$perlvar{'lonDaemons'};
1.98 foxr 1170: &Debug("Opening lcpasswd pipeline");
1.132 matthew 1171: my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
1.72 matthew 1172: print $pf "$uname\n$npass\n$npass\n";
1173: close $pf;
1.97 foxr 1174: my $err = $?;
1175: my $result = ($err>0 ? 'pwchange_failure'
1.72 matthew 1176: : 'ok');
1.96 foxr 1177: &logthis("Result of password change for $uname: ".
1178: &lcpasswdstrerror($?));
1.72 matthew 1179: print $client "$result\n";
1180: } else {
1181: print $client "non_authorized\n";
1182: }
1183: } else {
1.2 www 1184: print $client "auth_mode_error\n";
1.1 albertel 1185: }
1186: } else {
1187: print $client "unknown_user\n";
1.31 www 1188: }
1189: } else {
1190: print $client "refused\n";
1191: }
1192: # -------------------------------------------------------------------- makeuser
1193: } elsif ($userinput =~ /^makeuser/) {
1.91 albertel 1194: &Debug("Make user received");
1.56 harris41 1195: my $oldumask=umask(0077);
1.31 www 1196: if ($wasenc==1) {
1197: my
1198: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
1.77 foxr 1199: &Debug("cmd =".$cmd." $udom =".$udom.
1200: " uname=".$uname);
1.31 www 1201: chomp($npass);
1.32 www 1202: $npass=&unescape($npass);
1.31 www 1203: my $proname=propath($udom,$uname);
1204: my $passfilename="$proname/passwd";
1.77 foxr 1205: &Debug("Password file created will be:".
1206: $passfilename);
1.31 www 1207: if (-e $passfilename) {
1208: print $client "already_exists\n";
1.115 albertel 1209: } elsif ($udom ne $currentdomainid) {
1.31 www 1210: print $client "not_right_domain\n";
1211: } else {
1.134 albertel 1212: my @fpparts=split(/\//,$proname);
1213: my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
1214: my $fperror='';
1215: for (my $i=3;$i<=$#fpparts;$i++) {
1.31 www 1216: $fpnow.='/'.$fpparts[$i];
1217: unless (-e $fpnow) {
1218: unless (mkdir($fpnow,0777)) {
1.109 foxr 1219: $fperror="error: ".($!+0)
1.111 matthew 1220: ." mkdir failed while attempting "
1221: ."makeuser\n";
1.31 www 1222: }
1223: }
1224: }
1225: unless ($fperror) {
1.98 foxr 1226: my $result=&make_passwd_file($uname, $umode,$npass,
1.91 albertel 1227: $passfilename);
1228: print $client $result;
1.31 www 1229: } else {
1230: print $client "$fperror\n";
1231: }
1.55 harris41 1232: }
1233: } else {
1234: print $client "refused\n";
1235: }
1.56 harris41 1236: umask($oldumask);
1.55 harris41 1237: # -------------------------------------------------------------- changeuserauth
1238: } elsif ($userinput =~ /^changeuserauth/) {
1.77 foxr 1239: &Debug("Changing authorization");
1240: if ($wasenc==1) {
1.55 harris41 1241: my
1.91 albertel 1242: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
1.55 harris41 1243: chomp($npass);
1.77 foxr 1244: &Debug("cmd = ".$cmd." domain= ".$udom.
1245: "uname =".$uname." umode= ".$umode);
1.55 harris41 1246: $npass=&unescape($npass);
1.91 albertel 1247: my $proname=&propath($udom,$uname);
1.55 harris41 1248: my $passfilename="$proname/passwd";
1.115 albertel 1249: if ($udom ne $currentdomainid) {
1.55 harris41 1250: print $client "not_right_domain\n";
1251: } else {
1.98 foxr 1252: my $result=&make_passwd_file($uname, $umode,$npass,
1.93 albertel 1253: $passfilename);
1.91 albertel 1254: print $client $result;
1.1 albertel 1255: }
1256: } else {
1257: print $client "refused\n";
1258: }
1259: # ------------------------------------------------------------------------ home
1260: } elsif ($userinput =~ /^home/) {
1261: my ($cmd,$udom,$uname)=split(/:/,$userinput);
1262: chomp($uname);
1263: my $proname=propath($udom,$uname);
1264: if (-e $proname) {
1265: print $client "found\n";
1266: } else {
1267: print $client "not_found\n";
1268: }
1269: # ---------------------------------------------------------------------- update
1270: } elsif ($userinput =~ /^update/) {
1271: my ($cmd,$fname)=split(/:/,$userinput);
1272: my $ownership=ishome($fname);
1273: if ($ownership eq 'not_owner') {
1274: if (-e $fname) {
1275: my ($dev,$ino,$mode,$nlink,
1276: $uid,$gid,$rdev,$size,
1277: $atime,$mtime,$ctime,
1278: $blksize,$blocks)=stat($fname);
1.134 albertel 1279: my $now=time;
1280: my $since=$now-$atime;
1.1 albertel 1281: if ($since>$perlvar{'lonExpire'}) {
1.134 albertel 1282: my $reply=
1283: &reply("unsub:$fname","$hostid{$clientip}");
1.1 albertel 1284: unlink("$fname");
1285: } else {
1286: my $transname="$fname.in.transfer";
1287: my $remoteurl=
1288: reply("sub:$fname","$hostid{$clientip}");
1289: my $response;
1290: {
1291: my $ua=new LWP::UserAgent;
1292: my $request=new HTTP::Request('GET',"$remoteurl");
1293: $response=$ua->request($request,$transname);
1294: }
1295: if ($response->is_error()) {
1.24 albertel 1296: unlink($transname);
1.1 albertel 1297: my $message=$response->status_line;
1298: &logthis(
1299: "LWP GET: $message for $fname ($remoteurl)");
1300: } else {
1.14 www 1301: if ($remoteurl!~/\.meta$/) {
1.28 www 1302: my $ua=new LWP::UserAgent;
1.14 www 1303: my $mrequest=
1304: new HTTP::Request('GET',$remoteurl.'.meta');
1305: my $mresponse=
1306: $ua->request($mrequest,$fname.'.meta');
1307: if ($mresponse->is_error()) {
1308: unlink($fname.'.meta');
1309: }
1310: }
1.1 albertel 1311: rename($transname,$fname);
1312: }
1313: }
1314: print $client "ok\n";
1315: } else {
1316: print $client "not_found\n";
1317: }
1318: } else {
1319: print $client "rejected\n";
1320: }
1.85 www 1321: # -------------------------------------- fetch a user file from a remote server
1322: } elsif ($userinput =~ /^fetchuserfile/) {
1.86 www 1323: my ($cmd,$fname)=split(/:/,$userinput);
1324: my ($udom,$uname,$ufile)=split(/\//,$fname);
1325: my $udir=propath($udom,$uname).'/userfiles';
1.88 albertel 1326: unless (-e $udir) { mkdir($udir,0770); }
1.86 www 1327: if (-e $udir) {
1328: $ufile=~s/^[\.\~]+//;
1329: $ufile=~s/\///g;
1330: my $transname=$udir.'/'.$ufile;
1331: my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
1332: my $response;
1333: {
1334: my $ua=new LWP::UserAgent;
1335: my $request=new HTTP::Request('GET',"$remoteurl");
1336: $response=$ua->request($request,$transname);
1337: }
1338: if ($response->is_error()) {
1339: unlink($transname);
1340: my $message=$response->status_line;
1341: &logthis(
1342: "LWP GET: $message for $fname ($remoteurl)");
1343: print $client "failed\n";
1344: } else {
1345: print $client "ok\n";
1346: }
1347: } else {
1348: print $client "not_home\n";
1349: }
1.85 www 1350: # ------------------------------------------ authenticate access to a user file
1.86 www 1351: } elsif ($userinput =~ /^tokenauthuserfile/) {
1.85 www 1352: my ($cmd,$fname,$session)=split(/:/,$userinput);
1.86 www 1353: chomp($session);
1.134 albertel 1354: my $reply='non_auth';
1.86 www 1355: if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
1.134 albertel 1356: $session.'.id')) {
1357: while (my $line=<ENVIN>) {
1358: if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
1359: }
1360: close(ENVIN);
1361: print $client $reply."\n";
1.86 www 1362: } else {
1.134 albertel 1363: print $client "invalid_token\n";
1.86 www 1364: }
1.1 albertel 1365: # ----------------------------------------------------------------- unsubscribe
1366: } elsif ($userinput =~ /^unsub/) {
1367: my ($cmd,$fname)=split(/:/,$userinput);
1368: if (-e $fname) {
1.84 albertel 1369: print $client &unsub($client,$fname,$clientip);
1.1 albertel 1370: } else {
1371: print $client "not_found\n";
1372: }
1373: # ------------------------------------------------------------------- subscribe
1374: } elsif ($userinput =~ /^sub/) {
1.84 albertel 1375: print $client &subscribe($userinput,$clientip);
1.102 www 1376: # ------------------------------------------------------------- current version
1377: } elsif ($userinput =~ /^currentversion/) {
1378: my ($cmd,$fname)=split(/:/,$userinput);
1379: print $client ¤tversion($fname)."\n";
1.12 harris41 1380: # ------------------------------------------------------------------------- log
1381: } elsif ($userinput =~ /^log/) {
1382: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
1383: chomp($what);
1384: my $proname=propath($udom,$uname);
1385: my $now=time;
1386: {
1387: my $hfh;
1388: if ($hfh=IO::File->new(">>$proname/activity.log")) {
1389: print $hfh "$now:$hostid{$clientip}:$what\n";
1390: print $client "ok\n";
1391: } else {
1.109 foxr 1392: print $client "error: ".($!+0)
1.111 matthew 1393: ." IO::File->new Failed "
1394: ."while attempting log\n";
1.12 harris41 1395: }
1396: }
1.1 albertel 1397: # ------------------------------------------------------------------------- put
1398: } elsif ($userinput =~ /^put/) {
1.6 www 1399: my ($cmd,$udom,$uname,$namespace,$what)
1.1 albertel 1400: =split(/:/,$userinput);
1.8 www 1401: $namespace=~s/\//\_/g;
1.6 www 1402: $namespace=~s/\W//g;
1403: if ($namespace ne 'roles') {
1.1 albertel 1404: chomp($what);
1405: my $proname=propath($udom,$uname);
1406: my $now=time;
1.48 www 1407: unless ($namespace=~/^nohist\_/) {
1.1 albertel 1408: my $hfh;
1409: if (
1410: $hfh=IO::File->new(">>$proname/$namespace.hist")
1411: ) { print $hfh "P:$now:$what\n"; }
1412: }
1413: my @pairs=split(/\&/,$what);
1.134 albertel 1414: my %hash;
1415: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1416: foreach my $pair (@pairs) {
1417: my ($key,$value)=split(/=/,$pair);
1.1 albertel 1418: $hash{$key}=$value;
1419: }
1.4 www 1420: if (untie(%hash)) {
1.1 albertel 1421: print $client "ok\n";
1422: } else {
1.109 foxr 1423: print $client "error: ".($!+0)
1.111 matthew 1424: ." untie(GDBM) failed ".
1425: "while attempting put\n";
1.1 albertel 1426: }
1427: } else {
1.109 foxr 1428: print $client "error: ".($!)
1.111 matthew 1429: ." tie(GDBM) Failed ".
1430: "while attempting put\n";
1.1 albertel 1431: }
1.6 www 1432: } else {
1433: print $client "refused\n";
1434: }
1435: # -------------------------------------------------------------------- rolesput
1436: } elsif ($userinput =~ /^rolesput/) {
1.77 foxr 1437: &Debug("rolesput");
1.6 www 1438: if ($wasenc==1) {
1439: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
1440: =split(/:/,$userinput);
1.77 foxr 1441: &Debug("cmd = ".$cmd." exedom= ".$exedom.
1442: "user = ".$exeuser." udom=".$udom.
1443: "what = ".$what);
1.6 www 1444: my $namespace='roles';
1445: chomp($what);
1446: my $proname=propath($udom,$uname);
1447: my $now=time;
1448: {
1449: my $hfh;
1450: if (
1451: $hfh=IO::File->new(">>$proname/$namespace.hist")
1452: ) {
1453: print $hfh "P:$now:$exedom:$exeuser:$what\n";
1454: }
1455: }
1456: my @pairs=split(/\&/,$what);
1.134 albertel 1457: my %hash;
1458: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1459: foreach my $pair (@pairs) {
1460: my ($key,$value)=split(/=/,$pair);
1.78 foxr 1461: &ManagePermissions($key, $udom, $uname,
1462: &GetAuthType( $udom,
1463: $uname));
1.6 www 1464: $hash{$key}=$value;
1465: }
1466: if (untie(%hash)) {
1467: print $client "ok\n";
1468: } else {
1.109 foxr 1469: print $client "error: ".($!+0)
1.111 matthew 1470: ." untie(GDBM) Failed ".
1471: "while attempting rolesput\n";
1.6 www 1472: }
1473: } else {
1.109 foxr 1474: print $client "error: ".($!+0)
1.111 matthew 1475: ." tie(GDBM) Failed ".
1476: "while attempting rolesput\n";
1.117 www 1477: }
1478: } else {
1479: print $client "refused\n";
1480: }
1481: # -------------------------------------------------------------------- rolesdel
1482: } elsif ($userinput =~ /^rolesdel/) {
1483: &Debug("rolesdel");
1484: if ($wasenc==1) {
1485: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
1486: =split(/:/,$userinput);
1487: &Debug("cmd = ".$cmd." exedom= ".$exedom.
1488: "user = ".$exeuser." udom=".$udom.
1489: "what = ".$what);
1490: my $namespace='roles';
1491: chomp($what);
1492: my $proname=propath($udom,$uname);
1493: my $now=time;
1494: {
1495: my $hfh;
1496: if (
1497: $hfh=IO::File->new(">>$proname/$namespace.hist")
1498: ) {
1499: print $hfh "D:$now:$exedom:$exeuser:$what\n";
1500: }
1501: }
1502: my @rolekeys=split(/\&/,$what);
1.134 albertel 1503: my %hash;
1504: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1505: foreach my $key (@rolekeys) {
1.117 www 1506: delete $hash{$key};
1507: }
1508: if (untie(%hash)) {
1509: print $client "ok\n";
1510: } else {
1511: print $client "error: ".($!+0)
1512: ." untie(GDBM) Failed ".
1513: "while attempting rolesdel\n";
1514: }
1515: } else {
1516: print $client "error: ".($!+0)
1517: ." tie(GDBM) Failed ".
1518: "while attempting rolesdel\n";
1.6 www 1519: }
1520: } else {
1521: print $client "refused\n";
1522: }
1.1 albertel 1523: # ------------------------------------------------------------------------- get
1524: } elsif ($userinput =~ /^get/) {
1525: my ($cmd,$udom,$uname,$namespace,$what)
1526: =split(/:/,$userinput);
1.8 www 1527: $namespace=~s/\//\_/g;
1.1 albertel 1528: $namespace=~s/\W//g;
1529: chomp($what);
1530: my @queries=split(/\&/,$what);
1531: my $proname=propath($udom,$uname);
1532: my $qresult='';
1.134 albertel 1533: my %hash;
1534: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1535: for (my $i=0;$i<=$#queries;$i++) {
1.1 albertel 1536: $qresult.="$hash{$queries[$i]}&";
1537: }
1.4 www 1538: if (untie(%hash)) {
1.1 albertel 1539: $qresult=~s/\&$//;
1540: print $client "$qresult\n";
1541: } else {
1.109 foxr 1542: print $client "error: ".($!+0)
1.111 matthew 1543: ." untie(GDBM) Failed ".
1544: "while attempting get\n";
1.1 albertel 1545: }
1546: } else {
1.112 matthew 1547: if ($!+0 == 2) {
1548: print $client "error:No such file or ".
1549: "GDBM reported bad block error\n";
1550: } else {
1551: print $client "error: ".($!+0)
1552: ." tie(GDBM) Failed ".
1553: "while attempting get\n";
1554: }
1.1 albertel 1555: }
1556: # ------------------------------------------------------------------------ eget
1557: } elsif ($userinput =~ /^eget/) {
1558: my ($cmd,$udom,$uname,$namespace,$what)
1559: =split(/:/,$userinput);
1.8 www 1560: $namespace=~s/\//\_/g;
1.1 albertel 1561: $namespace=~s/\W//g;
1562: chomp($what);
1563: my @queries=split(/\&/,$what);
1564: my $proname=propath($udom,$uname);
1565: my $qresult='';
1.134 albertel 1566: my %hash;
1567: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1568: for (my $i=0;$i<=$#queries;$i++) {
1.1 albertel 1569: $qresult.="$hash{$queries[$i]}&";
1570: }
1.4 www 1571: if (untie(%hash)) {
1.1 albertel 1572: $qresult=~s/\&$//;
1573: if ($cipher) {
1574: my $cmdlength=length($qresult);
1575: $qresult.=" ";
1576: my $encqresult='';
1577: for
1578: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
1579: $encqresult.=
1580: unpack("H16",
1581: $cipher->encrypt(substr($qresult,$encidx,8)));
1582: }
1583: print $client "enc:$cmdlength:$encqresult\n";
1584: } else {
1585: print $client "error:no_key\n";
1586: }
1587: } else {
1.109 foxr 1588: print $client "error: ".($!+0)
1.111 matthew 1589: ." untie(GDBM) Failed ".
1590: "while attempting eget\n";
1.1 albertel 1591: }
1592: } else {
1.109 foxr 1593: print $client "error: ".($!+0)
1.111 matthew 1594: ." tie(GDBM) Failed ".
1595: "while attempting eget\n";
1.1 albertel 1596: }
1597: # ------------------------------------------------------------------------- del
1598: } elsif ($userinput =~ /^del/) {
1599: my ($cmd,$udom,$uname,$namespace,$what)
1600: =split(/:/,$userinput);
1.8 www 1601: $namespace=~s/\//\_/g;
1.1 albertel 1602: $namespace=~s/\W//g;
1603: chomp($what);
1604: my $proname=propath($udom,$uname);
1605: my $now=time;
1.48 www 1606: unless ($namespace=~/^nohist\_/) {
1.1 albertel 1607: my $hfh;
1608: if (
1609: $hfh=IO::File->new(">>$proname/$namespace.hist")
1610: ) { print $hfh "D:$now:$what\n"; }
1611: }
1612: my @keys=split(/\&/,$what);
1.134 albertel 1613: my %hash;
1614: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1615: foreach my $key (@keys) {
1.1 albertel 1616: delete($hash{$key});
1617: }
1.4 www 1618: if (untie(%hash)) {
1.1 albertel 1619: print $client "ok\n";
1620: } else {
1.109 foxr 1621: print $client "error: ".($!+0)
1.111 matthew 1622: ." untie(GDBM) Failed ".
1623: "while attempting del\n";
1.1 albertel 1624: }
1625: } else {
1.109 foxr 1626: print $client "error: ".($!+0)
1.111 matthew 1627: ." tie(GDBM) Failed ".
1628: "while attempting del\n";
1.1 albertel 1629: }
1630: # ------------------------------------------------------------------------ keys
1631: } elsif ($userinput =~ /^keys/) {
1632: my ($cmd,$udom,$uname,$namespace)
1633: =split(/:/,$userinput);
1.8 www 1634: $namespace=~s/\//\_/g;
1.1 albertel 1635: $namespace=~s/\W//g;
1636: my $proname=propath($udom,$uname);
1637: my $qresult='';
1.134 albertel 1638: my %hash;
1639: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1640: foreach my $key (keys %hash) {
1.1 albertel 1641: $qresult.="$key&";
1642: }
1.4 www 1643: if (untie(%hash)) {
1.1 albertel 1644: $qresult=~s/\&$//;
1645: print $client "$qresult\n";
1646: } else {
1.109 foxr 1647: print $client "error: ".($!+0)
1.111 matthew 1648: ." untie(GDBM) Failed ".
1649: "while attempting keys\n";
1.105 matthew 1650: }
1651: } else {
1.109 foxr 1652: print $client "error: ".($!+0)
1.111 matthew 1653: ." tie(GDBM) Failed ".
1654: "while attempting keys\n";
1.105 matthew 1655: }
1656: # ----------------------------------------------------------------- dumpcurrent
1.107 matthew 1657: } elsif ($userinput =~ /^currentdump/) {
1.105 matthew 1658: my ($cmd,$udom,$uname,$namespace)
1659: =split(/:/,$userinput);
1660: $namespace=~s/\//\_/g;
1661: $namespace=~s/\W//g;
1662: my $qresult='';
1663: my $proname=propath($udom,$uname);
1.134 albertel 1664: my %hash;
1.105 matthew 1665: if (tie(%hash,'GDBM_File',
1666: "$proname/$namespace.db",
1667: &GDBM_READER(),0640)) {
1668: # Structure of %data:
1669: # $data{$symb}->{$parameter}=$value;
1670: # $data{$symb}->{'v.'.$parameter}=$version;
1671: # since $parameter will be unescaped, we do not
1672: # have to worry about silly parameter names...
1673: my %data = ();
1674: while (my ($key,$value) = each(%hash)) {
1675: my ($v,$symb,$param) = split(/:/,$key);
1676: next if ($v eq 'version' || $symb eq 'keys');
1677: next if (exists($data{$symb}) &&
1678: exists($data{$symb}->{$param}) &&
1679: $data{$symb}->{'v.'.$param} > $v);
1680: $data{$symb}->{$param}=$value;
1.107 matthew 1681: $data{$symb}->{'v.'.$param}=$v;
1.105 matthew 1682: }
1683: if (untie(%hash)) {
1684: while (my ($symb,$param_hash) = each(%data)) {
1685: while(my ($param,$value) = each (%$param_hash)){
1686: next if ($param =~ /^v\./);
1687: $qresult.=$symb.':'.$param.'='.$value.'&';
1688: }
1689: }
1690: chop($qresult);
1691: print $client "$qresult\n";
1692: } else {
1.109 foxr 1693: print $client "error: ".($!+0)
1.111 matthew 1694: ." untie(GDBM) Failed ".
1695: "while attempting currentdump\n";
1.1 albertel 1696: }
1697: } else {
1.109 foxr 1698: print $client "error: ".($!+0)
1.111 matthew 1699: ." tie(GDBM) Failed ".
1700: "while attempting currentdump\n";
1.1 albertel 1701: }
1702: # ------------------------------------------------------------------------ dump
1703: } elsif ($userinput =~ /^dump/) {
1.62 www 1704: my ($cmd,$udom,$uname,$namespace,$regexp)
1.1 albertel 1705: =split(/:/,$userinput);
1.8 www 1706: $namespace=~s/\//\_/g;
1.1 albertel 1707: $namespace=~s/\W//g;
1.62 www 1708: if (defined($regexp)) {
1709: $regexp=&unescape($regexp);
1710: } else {
1711: $regexp='.';
1712: }
1.100 matthew 1713: my $qresult='';
1.1 albertel 1714: my $proname=propath($udom,$uname);
1.134 albertel 1715: my %hash;
1716: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1.90 stredwic 1717: study($regexp);
1.134 albertel 1718: while (my ($key,$value) = each(%hash)) {
1.100 matthew 1719: if ($regexp eq '.') {
1720: $qresult.=$key.'='.$value.'&';
1721: } else {
1722: my $unescapeKey = &unescape($key);
1723: if (eval('$unescapeKey=~/$regexp/')) {
1724: $qresult.="$key=$value&";
1725: }
1726: }
1.7 www 1727: }
1.100 matthew 1728: if (untie(%hash)) {
1729: chop($qresult);
1730: print $client "$qresult\n";
1.7 www 1731: } else {
1.109 foxr 1732: print $client "error: ".($!+0)
1.111 matthew 1733: ." untie(GDBM) Failed ".
1734: "while attempting dump\n";
1.7 www 1735: }
1736: } else {
1.109 foxr 1737: print $client "error: ".($!+0)
1.111 matthew 1738: ." tie(GDBM) Failed ".
1739: "while attempting dump\n";
1.7 www 1740: }
1741: # ----------------------------------------------------------------------- store
1742: } elsif ($userinput =~ /^store/) {
1743: my ($cmd,$udom,$uname,$namespace,$rid,$what)
1744: =split(/:/,$userinput);
1.8 www 1745: $namespace=~s/\//\_/g;
1.7 www 1746: $namespace=~s/\W//g;
1747: if ($namespace ne 'roles') {
1748: chomp($what);
1749: my $proname=propath($udom,$uname);
1750: my $now=time;
1.48 www 1751: unless ($namespace=~/^nohist\_/) {
1.7 www 1752: my $hfh;
1753: if (
1754: $hfh=IO::File->new(">>$proname/$namespace.hist")
1755: ) { print $hfh "P:$now:$rid:$what\n"; }
1756: }
1757: my @pairs=split(/\&/,$what);
1.134 albertel 1758: my %hash;
1759: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
1.7 www 1760: my @previouskeys=split(/&/,$hash{"keys:$rid"});
1761: my $key;
1762: $hash{"version:$rid"}++;
1763: my $version=$hash{"version:$rid"};
1764: my $allkeys='';
1.134 albertel 1765: foreach my $pair (@pairs) {
1766: my ($key,$value)=split(/=/,$pair);
1.7 www 1767: $allkeys.=$key.':';
1768: $hash{"$version:$rid:$key"}=$value;
1769: }
1.36 www 1770: $hash{"$version:$rid:timestamp"}=$now;
1771: $allkeys.='timestamp';
1.7 www 1772: $hash{"$version:keys:$rid"}=$allkeys;
1773: if (untie(%hash)) {
1774: print $client "ok\n";
1775: } else {
1.109 foxr 1776: print $client "error: ".($!+0)
1.111 matthew 1777: ." untie(GDBM) Failed ".
1778: "while attempting store\n";
1.7 www 1779: }
1780: } else {
1.109 foxr 1781: print $client "error: ".($!+0)
1.111 matthew 1782: ." tie(GDBM) Failed ".
1783: "while attempting store\n";
1.7 www 1784: }
1785: } else {
1786: print $client "refused\n";
1787: }
1788: # --------------------------------------------------------------------- restore
1789: } elsif ($userinput =~ /^restore/) {
1790: my ($cmd,$udom,$uname,$namespace,$rid)
1791: =split(/:/,$userinput);
1.8 www 1792: $namespace=~s/\//\_/g;
1.7 www 1793: $namespace=~s/\W//g;
1794: chomp($rid);
1795: my $proname=propath($udom,$uname);
1796: my $qresult='';
1.134 albertel 1797: my %hash;
1798: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
1.7 www 1799: my $version=$hash{"version:$rid"};
1800: $qresult.="version=$version&";
1801: my $scope;
1802: for ($scope=1;$scope<=$version;$scope++) {
1803: my $vkeys=$hash{"$scope:keys:$rid"};
1804: my @keys=split(/:/,$vkeys);
1805: my $key;
1806: $qresult.="$scope:keys=$vkeys&";
1807: foreach $key (@keys) {
1.21 www 1808: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1.7 www 1809: }
1.1 albertel 1810: }
1.4 www 1811: if (untie(%hash)) {
1.1 albertel 1812: $qresult=~s/\&$//;
1813: print $client "$qresult\n";
1814: } else {
1.109 foxr 1815: print $client "error: ".($!+0)
1.111 matthew 1816: ." untie(GDBM) Failed ".
1817: "while attempting restore\n";
1.1 albertel 1818: }
1819: } else {
1.109 foxr 1820: print $client "error: ".($!+0)
1.111 matthew 1821: ." tie(GDBM) Failed ".
1822: "while attempting restore\n";
1.1 albertel 1823: }
1.86 www 1824: # -------------------------------------------------------------------- chatsend
1825: } elsif ($userinput =~ /^chatsend/) {
1826: my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
1827: &chatadd($cdom,$cnum,$newpost);
1828: print $client "ok\n";
1829: # -------------------------------------------------------------------- chatretr
1830: } elsif ($userinput =~ /^chatretr/) {
1.122 www 1831: my
1832: ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
1.86 www 1833: my $reply='';
1.122 www 1834: foreach (&getchat($cdom,$cnum,$udom,$uname)) {
1.86 www 1835: $reply.=&escape($_).':';
1836: }
1837: $reply=~s/\:$//;
1838: print $client $reply."\n";
1.12 harris41 1839: # ------------------------------------------------------------------- querysend
1840: } elsif ($userinput =~ /^querysend/) {
1.44 harris41 1841: my ($cmd,$query,
1.82 www 1842: $arg1,$arg2,$arg3)=split(/\:/,$userinput);
1.12 harris41 1843: $query=~s/\n*$//g;
1.82 www 1844: print $client "".
1.40 harris41 1845: sqlreply("$hostid{$clientip}\&$query".
1.82 www 1846: "\&$arg1"."\&$arg2"."\&$arg3")."\n";
1.12 harris41 1847: # ------------------------------------------------------------------ queryreply
1848: } elsif ($userinput =~ /^queryreply/) {
1849: my ($cmd,$id,$reply)=split(/:/,$userinput);
1850: my $store;
1.13 www 1851: my $execdir=$perlvar{'lonDaemons'};
1852: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1.43 harris41 1853: $reply=~s/\&/\n/g;
1.12 harris41 1854: print $store $reply;
1855: close $store;
1.46 harris41 1856: my $store2=IO::File->new(">$execdir/tmp/$id.end");
1857: print $store2 "done\n";
1858: close $store2;
1.12 harris41 1859: print $client "ok\n";
1860: }
1861: else {
1.109 foxr 1862: print $client "error: ".($!+0)
1.111 matthew 1863: ." IO::File->new Failed ".
1864: "while attempting queryreply\n";
1.12 harris41 1865: }
1.118 www 1866: # ----------------------------------------------------------------- courseidput
1867: } elsif ($userinput =~ /^courseidput/) {
1868: my ($cmd,$udom,$what)=split(/:/,$userinput);
1869: chomp($what);
1870: $udom=~s/\W//g;
1871: my $proname=
1872: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
1873: my $now=time;
1874: my @pairs=split(/\&/,$what);
1.134 albertel 1875: my %hash;
1876: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
1877: foreach my $pair (@pairs) {
1878: my ($key,$value)=split(/=/,$pair);
1.118 www 1879: $hash{$key}=$value.':'.$now;
1880: }
1881: if (untie(%hash)) {
1882: print $client "ok\n";
1883: } else {
1884: print $client "error: ".($!+0)
1885: ." untie(GDBM) Failed ".
1886: "while attempting courseidput\n";
1887: }
1888: } else {
1889: print $client "error: ".($!+0)
1890: ." tie(GDBM) Failed ".
1891: "while attempting courseidput\n";
1892: }
1893: # ---------------------------------------------------------------- courseiddump
1894: } elsif ($userinput =~ /^courseiddump/) {
1895: my ($cmd,$udom,$since,$description)
1896: =split(/:/,$userinput);
1897: if (defined($description)) {
1898: $description=&unescape($description);
1899: } else {
1900: $description='.';
1901: }
1902: unless (defined($since)) { $since=0; }
1903: my $qresult='';
1904: my $proname=
1905: "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
1.134 albertel 1906: my %hash;
1907: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
1908: while (my ($key,$value) = each(%hash)) {
1.118 www 1909: my ($descr,$lasttime)=split(/\:/,$value);
1910: if ($lasttime<$since) { next; }
1.133 www 1911: if ($description eq '.') {
1.118 www 1912: $qresult.=$key.'='.$descr.'&';
1913: } else {
1914: my $unescapeVal = &unescape($descr);
1.120 www 1915: if (eval('$unescapeVal=~/$description/i')) {
1.118 www 1916: $qresult.="$key=$descr&";
1917: }
1918: }
1919: }
1920: if (untie(%hash)) {
1921: chop($qresult);
1922: print $client "$qresult\n";
1923: } else {
1924: print $client "error: ".($!+0)
1925: ." untie(GDBM) Failed ".
1926: "while attempting courseiddump\n";
1927: }
1928: } else {
1929: print $client "error: ".($!+0)
1930: ." tie(GDBM) Failed ".
1931: "while attempting courseiddump\n";
1932: }
1.1 albertel 1933: # ----------------------------------------------------------------------- idput
1934: } elsif ($userinput =~ /^idput/) {
1935: my ($cmd,$udom,$what)=split(/:/,$userinput);
1936: chomp($what);
1937: $udom=~s/\W//g;
1938: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1939: my $now=time;
1940: {
1941: my $hfh;
1942: if (
1943: $hfh=IO::File->new(">>$proname.hist")
1944: ) { print $hfh "P:$now:$what\n"; }
1945: }
1946: my @pairs=split(/\&/,$what);
1.134 albertel 1947: my %hash;
1948: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
1949: foreach my $pair (@pairs) {
1950: my ($key,$value)=split(/=/,$pair);
1.1 albertel 1951: $hash{$key}=$value;
1952: }
1.4 www 1953: if (untie(%hash)) {
1.1 albertel 1954: print $client "ok\n";
1955: } else {
1.109 foxr 1956: print $client "error: ".($!+0)
1.111 matthew 1957: ." untie(GDBM) Failed ".
1958: "while attempting idput\n";
1.1 albertel 1959: }
1960: } else {
1.109 foxr 1961: print $client "error: ".($!+0)
1.111 matthew 1962: ." tie(GDBM) Failed ".
1963: "while attempting idput\n";
1.1 albertel 1964: }
1965: # ----------------------------------------------------------------------- idget
1966: } elsif ($userinput =~ /^idget/) {
1967: my ($cmd,$udom,$what)=split(/:/,$userinput);
1968: chomp($what);
1969: $udom=~s/\W//g;
1970: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1971: my @queries=split(/\&/,$what);
1972: my $qresult='';
1.134 albertel 1973: my %hash;
1974: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
1975: for (my $i=0;$i<=$#queries;$i++) {
1.1 albertel 1976: $qresult.="$hash{$queries[$i]}&";
1977: }
1.4 www 1978: if (untie(%hash)) {
1.134 albertel 1979: $qresult=~s/\&$//;
1980: print $client "$qresult\n";
1.1 albertel 1981: } else {
1.134 albertel 1982: print $client "error: ".($!+0)
1983: ." untie(GDBM) Failed ".
1984: "while attempting idget\n";
1.1 albertel 1985: }
1986: } else {
1.109 foxr 1987: print $client "error: ".($!+0)
1.111 matthew 1988: ." tie(GDBM) Failed ".
1989: "while attempting idget\n";
1.1 albertel 1990: }
1.13 www 1991: # ---------------------------------------------------------------------- tmpput
1992: } elsif ($userinput =~ /^tmpput/) {
1993: my ($cmd,$what)=split(/:/,$userinput);
1994: my $store;
1995: $tmpsnum++;
1996: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
1997: $id=~s/\W/\_/g;
1998: $what=~s/\n//g;
1999: my $execdir=$perlvar{'lonDaemons'};
2000: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
2001: print $store $what;
2002: close $store;
2003: print $client "$id\n";
2004: }
2005: else {
1.109 foxr 2006: print $client "error: ".($!+0)
1.111 matthew 2007: ."IO::File->new Failed ".
2008: "while attempting tmpput\n";
1.13 www 2009: }
2010:
2011: # ---------------------------------------------------------------------- tmpget
2012: } elsif ($userinput =~ /^tmpget/) {
2013: my ($cmd,$id)=split(/:/,$userinput);
2014: chomp($id);
2015: $id=~s/\W/\_/g;
2016: my $store;
2017: my $execdir=$perlvar{'lonDaemons'};
2018: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
2019: my $reply=<$store>;
2020: print $client "$reply\n";
2021: close $store;
2022: }
2023: else {
1.109 foxr 2024: print $client "error: ".($!+0)
1.111 matthew 2025: ."IO::File->new Failed ".
2026: "while attempting tmpget\n";
1.13 www 2027: }
2028:
1.110 www 2029: # ---------------------------------------------------------------------- tmpdel
2030: } elsif ($userinput =~ /^tmpdel/) {
2031: my ($cmd,$id)=split(/:/,$userinput);
2032: chomp($id);
2033: $id=~s/\W/\_/g;
2034: my $execdir=$perlvar{'lonDaemons'};
2035: if (unlink("$execdir/tmp/$id.tmp")) {
2036: print $client "ok\n";
2037: } else {
2038: print $client "error: ".($!+0)
1.111 matthew 2039: ."Unlink tmp Failed ".
2040: "while attempting tmpdel\n";
1.110 www 2041: }
1.5 www 2042: # -------------------------------------------------------------------------- ls
2043: } elsif ($userinput =~ /^ls/) {
2044: my ($cmd,$ulsdir)=split(/:/,$userinput);
2045: my $ulsout='';
2046: my $ulsfn;
2047: if (-e $ulsdir) {
1.83 stredwic 2048: if(-d $ulsdir) {
2049: if (opendir(LSDIR,$ulsdir)) {
2050: while ($ulsfn=readdir(LSDIR)) {
2051: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
2052: $ulsout.=$ulsfn.'&'.
2053: join('&',@ulsstats).':';
2054: }
2055: closedir(LSDIR);
2056: }
2057: } else {
2058: my @ulsstats=stat($ulsdir);
2059: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
2060: }
2061: } else {
1.5 www 2062: $ulsout='no_such_dir';
2063: }
1.17 www 2064: if ($ulsout eq '') { $ulsout='empty'; }
1.5 www 2065: print $client "$ulsout\n";
1.136 www 2066: # ----------------------------------------------------------------- setannounce
2067: } elsif ($userinput =~ /^setannounce/) {
2068: my ($cmd,$announcement)=split(/:/,$userinput);
2069: chomp($announcement);
2070: $announcement=&unescape($announcement);
2071: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
2072: '/announcement.txt')) {
2073: print $store $announcement;
2074: close $store;
2075: print $client "ok\n";
2076: } else {
2077: print $client "error: ".($!+0)."\n";
2078: }
1.51 www 2079: # ------------------------------------------------------------------ Hanging up
2080: } elsif (($userinput =~ /^exit/) ||
2081: ($userinput =~ /^init/)) {
2082: &logthis(
2083: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
2084: print $client "bye\n";
1.59 www 2085: $client->close();
1.51 www 2086: last;
1.1 albertel 2087: # ------------------------------------------------------------- unknown command
1.121 albertel 2088: } elsif ($userinput =~ /^sethost:/) {
2089: print $client &sethost($userinput)."\n";
2090: } elsif ($userinput =~/^version:/) {
2091: print $client &version($userinput)."\n";
1.1 albertel 2092: } else {
2093: # unknown command
2094: print $client "unknown_cmd\n";
2095: }
1.58 www 2096: # -------------------------------------------------------------------- complete
1.63 www 2097: alarm(0);
1.58 www 2098: &status('Listening to '.$hostid{$clientip});
2099: }
1.59 www 2100: # --------------------------------------------- client unknown or fishy, refuse
1.1 albertel 2101: } else {
2102: print $client "refused\n";
1.59 www 2103: $client->close();
1.9 www 2104: &logthis("<font color=blue>WARNING: "
2105: ."Rejected client $clientip, closing connection</font>");
1.75 foxr 2106: }
1.106 foxr 2107: }
1.75 foxr 2108:
1.1 albertel 2109: # =============================================================================
1.75 foxr 2110:
2111: &logthis("<font color=red>CRITICAL: "
2112: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1.106 foxr 2113:
1.59 www 2114:
1.1 albertel 2115: # this exit is VERY important, otherwise the child will become
2116: # a producer of more and more children, forking yourself into
2117: # process death.
2118: exit;
1.106 foxr 2119:
1.78 foxr 2120: }
2121:
2122:
2123: #
2124: # Checks to see if the input roleput request was to set
2125: # an author role. If so, invokes the lchtmldir script to set
2126: # up a correct public_html
2127: # Parameters:
2128: # request - The request sent to the rolesput subchunk.
2129: # We're looking for /domain/_au
2130: # domain - The domain in which the user is having roles doctored.
2131: # user - Name of the user for which the role is being put.
2132: # authtype - The authentication type associated with the user.
2133: #
2134: sub ManagePermissions
2135: {
2136: my $request = shift;
2137: my $domain = shift;
2138: my $user = shift;
2139: my $authtype= shift;
2140:
2141: # See if the request is of the form /$domain/_au
1.134 albertel 2142: &logthis("ruequest is $request");
1.78 foxr 2143: if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
2144: my $execdir = $perlvar{'lonDaemons'};
2145: my $userhome= "/home/$user" ;
1.134 albertel 2146: &logthis("system $execdir/lchtmldir $userhome $user $authtype");
1.78 foxr 2147: system("$execdir/lchtmldir $userhome $user $authtype");
2148: }
2149: }
2150: #
2151: # GetAuthType - Determines the authorization type of a user in a domain.
2152:
2153: # Returns the authorization type or nouser if there is no such user.
2154: #
2155: sub GetAuthType
2156: {
2157: my $domain = shift;
2158: my $user = shift;
2159:
1.79 foxr 2160: Debug("GetAuthType( $domain, $user ) \n");
1.78 foxr 2161: my $proname = &propath($domain, $user);
2162: my $passwdfile = "$proname/passwd";
2163: if( -e $passwdfile ) {
2164: my $pf = IO::File->new($passwdfile);
2165: my $realpassword = <$pf>;
2166: chomp($realpassword);
1.79 foxr 2167: Debug("Password info = $realpassword\n");
1.78 foxr 2168: my ($authtype, $contentpwd) = split(/:/, $realpassword);
1.79 foxr 2169: Debug("Authtype = $authtype, content = $contentpwd\n");
1.78 foxr 2170: my $availinfo = '';
1.91 albertel 2171: if($authtype eq 'krb4' or $authtype eq 'krb5') {
1.78 foxr 2172: $availinfo = $contentpwd;
2173: }
1.79 foxr 2174:
1.78 foxr 2175: return "$authtype:$availinfo";
2176: }
2177: else {
1.79 foxr 2178: Debug("Returning nouser");
1.78 foxr 2179: return "nouser";
2180: }
1.1 albertel 2181: }
2182:
1.84 albertel 2183: sub addline {
2184: my ($fname,$hostid,$ip,$newline)=@_;
2185: my $contents;
2186: my $found=0;
2187: my $expr='^'.$hostid.':'.$ip.':';
2188: $expr =~ s/\./\\\./g;
1.134 albertel 2189: my $sh;
1.84 albertel 2190: if ($sh=IO::File->new("$fname.subscription")) {
2191: while (my $subline=<$sh>) {
2192: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
2193: }
2194: $sh->close();
2195: }
2196: $sh=IO::File->new(">$fname.subscription");
2197: if ($contents) { print $sh $contents; }
2198: if ($newline) { print $sh $newline; }
2199: $sh->close();
2200: return $found;
1.86 www 2201: }
2202:
2203: sub getchat {
1.122 www 2204: my ($cdom,$cname,$udom,$uname)=@_;
1.87 www 2205: my %hash;
2206: my $proname=&propath($cdom,$cname);
2207: my @entries=();
1.88 albertel 2208: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
2209: &GDBM_READER(),0640)) {
2210: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
2211: untie %hash;
1.123 www 2212: }
1.124 www 2213: my @participants=();
1.134 albertel 2214: my $cutoff=time-60;
1.123 www 2215: if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
1.124 www 2216: &GDBM_WRCREAT(),0640)) {
2217: $hash{$uname.':'.$udom}=time;
1.123 www 2218: foreach (sort keys %hash) {
2219: if ($hash{$_}>$cutoff) {
1.124 www 2220: $participants[$#participants+1]='active_participant:'.$_;
1.123 www 2221: }
2222: }
2223: untie %hash;
1.86 www 2224: }
1.124 www 2225: return (@participants,@entries);
1.86 www 2226: }
2227:
2228: sub chatadd {
1.88 albertel 2229: my ($cdom,$cname,$newchat)=@_;
2230: my %hash;
2231: my $proname=&propath($cdom,$cname);
2232: my @entries=();
1.142 www 2233: my $time=time;
1.88 albertel 2234: if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
2235: &GDBM_WRCREAT(),0640)) {
2236: @entries=map { $_.':'.$hash{$_} } sort keys %hash;
2237: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
2238: my ($thentime,$idnum)=split(/\_/,$lastid);
2239: my $newid=$time.'_000000';
2240: if ($thentime==$time) {
2241: $idnum=~s/^0+//;
2242: $idnum++;
2243: $idnum=substr('000000'.$idnum,-6,6);
2244: $newid=$time.'_'.$idnum;
2245: }
2246: $hash{$newid}=$newchat;
2247: my $expired=$time-3600;
2248: foreach (keys %hash) {
2249: my ($thistime)=($_=~/(\d+)\_/);
2250: if ($thistime<$expired) {
1.89 www 2251: delete $hash{$_};
1.88 albertel 2252: }
2253: }
2254: untie %hash;
1.142 www 2255: }
2256: {
2257: my $hfh;
2258: if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
2259: print $hfh "$time:".&unescape($newchat)."\n";
2260: }
1.86 www 2261: }
1.84 albertel 2262: }
2263:
2264: sub unsub {
2265: my ($fname,$clientip)=@_;
2266: my $result;
2267: if (unlink("$fname.$hostid{$clientip}")) {
2268: $result="ok\n";
2269: } else {
2270: $result="not_subscribed\n";
2271: }
2272: if (-e "$fname.subscription") {
2273: my $found=&addline($fname,$hostid{$clientip},$clientip,'');
2274: if ($found) { $result="ok\n"; }
2275: } else {
2276: if ($result != "ok\n") { $result="not_subscribed\n"; }
2277: }
2278: return $result;
2279: }
2280:
1.101 www 2281: sub currentversion {
2282: my $fname=shift;
2283: my $version=-1;
2284: my $ulsdir='';
2285: if ($fname=~/^(.+)\/[^\/]+$/) {
2286: $ulsdir=$1;
2287: }
1.114 albertel 2288: my ($fnamere1,$fnamere2);
2289: # remove version if already specified
1.101 www 2290: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
1.114 albertel 2291: # get the bits that go before and after the version number
2292: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
2293: $fnamere1=$1;
2294: $fnamere2='.'.$2;
2295: }
1.101 www 2296: if (-e $fname) { $version=1; }
2297: if (-e $ulsdir) {
1.134 albertel 2298: if(-d $ulsdir) {
2299: if (opendir(LSDIR,$ulsdir)) {
2300: my $ulsfn;
2301: while ($ulsfn=readdir(LSDIR)) {
1.101 www 2302: # see if this is a regular file (ignore links produced earlier)
1.134 albertel 2303: my $thisfile=$ulsdir.'/'.$ulsfn;
2304: unless (-l $thisfile) {
2305: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
2306: if ($1>$version) { $version=$1; }
2307: }
2308: }
2309: }
2310: closedir(LSDIR);
2311: $version++;
2312: }
2313: }
2314: }
2315: return $version;
1.101 www 2316: }
2317:
2318: sub thisversion {
2319: my $fname=shift;
2320: my $version=-1;
2321: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
2322: $version=$1;
2323: }
2324: return $version;
2325: }
2326:
1.84 albertel 2327: sub subscribe {
2328: my ($userinput,$clientip)=@_;
2329: my $result;
2330: my ($cmd,$fname)=split(/:/,$userinput);
2331: my $ownership=&ishome($fname);
2332: if ($ownership eq 'owner') {
1.101 www 2333: # explitly asking for the current version?
2334: unless (-e $fname) {
2335: my $currentversion=¤tversion($fname);
2336: if (&thisversion($fname)==$currentversion) {
2337: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
2338: my $root=$1;
2339: my $extension=$2;
2340: symlink($root.'.'.$extension,
2341: $root.'.'.$currentversion.'.'.$extension);
1.102 www 2342: unless ($extension=~/\.meta$/) {
2343: symlink($root.'.'.$extension.'.meta',
2344: $root.'.'.$currentversion.'.'.$extension.'.meta');
2345: }
1.101 www 2346: }
2347: }
2348: }
1.84 albertel 2349: if (-e $fname) {
2350: if (-d $fname) {
2351: $result="directory\n";
2352: } else {
2353: if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
1.134 albertel 2354: my $now=time;
1.84 albertel 2355: my $found=&addline($fname,$hostid{$clientip},$clientip,
2356: "$hostid{$clientip}:$clientip:$now\n");
2357: if ($found) { $result="$fname\n"; }
2358: # if they were subscribed to only meta data, delete that
2359: # subscription, when you subscribe to a file you also get
2360: # the metadata
2361: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
2362: $fname=~s/\/home\/httpd\/html\/res/raw/;
2363: $fname="http://$thisserver/".$fname;
2364: $result="$fname\n";
2365: }
2366: } else {
2367: $result="not_found\n";
2368: }
2369: } else {
2370: $result="rejected\n";
2371: }
2372: return $result;
2373: }
1.91 albertel 2374:
2375: sub make_passwd_file {
1.98 foxr 2376: my ($uname, $umode,$npass,$passfilename)=@_;
1.91 albertel 2377: my $result="ok\n";
2378: if ($umode eq 'krb4' or $umode eq 'krb5') {
2379: {
2380: my $pf = IO::File->new(">$passfilename");
2381: print $pf "$umode:$npass\n";
2382: }
2383: } elsif ($umode eq 'internal') {
2384: my $salt=time;
2385: $salt=substr($salt,6,2);
2386: my $ncpass=crypt($npass,$salt);
2387: {
2388: &Debug("Creating internal auth");
2389: my $pf = IO::File->new(">$passfilename");
2390: print $pf "internal:$ncpass\n";
2391: }
2392: } elsif ($umode eq 'localauth') {
2393: {
2394: my $pf = IO::File->new(">$passfilename");
2395: print $pf "localauth:$npass\n";
2396: }
2397: } elsif ($umode eq 'unix') {
2398: {
2399: my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
2400: {
2401: &Debug("Executing external: ".$execpath);
1.98 foxr 2402: &Debug("user = ".$uname.", Password =". $npass);
1.132 matthew 2403: my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
1.91 albertel 2404: print $se "$uname\n";
2405: print $se "$npass\n";
2406: print $se "$npass\n";
1.97 foxr 2407: }
2408: my $useraddok = $?;
2409: if($useraddok > 0) {
2410: &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
1.91 albertel 2411: }
2412: my $pf = IO::File->new(">$passfilename");
2413: print $pf "unix:\n";
2414: }
2415: } elsif ($umode eq 'none') {
2416: {
2417: my $pf = IO::File->new(">$passfilename");
2418: print $pf "none:\n";
2419: }
2420: } else {
2421: $result="auth_mode_error\n";
2422: }
2423: return $result;
1.121 albertel 2424: }
2425:
2426: sub sethost {
2427: my ($remotereq) = @_;
2428: my (undef,$hostid)=split(/:/,$remotereq);
2429: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
2430: if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
2431: $currenthostid=$hostid;
2432: $currentdomainid=$hostdom{$hostid};
2433: &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
2434: } else {
2435: &logthis("Requested host id $hostid not an alias of ".
2436: $perlvar{'lonHostID'}." refusing connection");
2437: return 'unable_to_set';
2438: }
2439: return 'ok';
2440: }
2441:
2442: sub version {
2443: my ($userinput)=@_;
2444: $remoteVERSION=(split(/:/,$userinput))[1];
2445: return "version:$VERSION";
1.127 albertel 2446: }
2447:
1.128 albertel 2448: #There is a copy of this in lonnet.pm
1.127 albertel 2449: sub userload {
2450: my $numusers=0;
2451: {
2452: opendir(LONIDS,$perlvar{'lonIDsDir'});
2453: my $filename;
2454: my $curtime=time;
2455: while ($filename=readdir(LONIDS)) {
2456: if ($filename eq '.' || $filename eq '..') {next;}
1.138 albertel 2457: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
2458: if ($curtime-$mtime < 3600) { $numusers++; }
1.127 albertel 2459: }
2460: closedir(LONIDS);
2461: }
2462: my $userloadpercent=0;
2463: my $maxuserload=$perlvar{'lonUserLoadLim'};
2464: if ($maxuserload) {
1.129 albertel 2465: $userloadpercent=100*$numusers/$maxuserload;
1.127 albertel 2466: }
1.130 albertel 2467: $userloadpercent=sprintf("%.2f",$userloadpercent);
1.127 albertel 2468: return $userloadpercent;
1.91 albertel 2469: }
2470:
1.61 harris41 2471: # ----------------------------------- POD (plain old documentation, CPAN style)
2472:
2473: =head1 NAME
2474:
2475: lond - "LON Daemon" Server (port "LOND" 5663)
2476:
2477: =head1 SYNOPSIS
2478:
1.74 harris41 2479: Usage: B<lond>
2480:
2481: Should only be run as user=www. This is a command-line script which
2482: is invoked by B<loncron>. There is no expectation that a typical user
2483: will manually start B<lond> from the command-line. (In other words,
2484: DO NOT START B<lond> YOURSELF.)
1.61 harris41 2485:
2486: =head1 DESCRIPTION
2487:
1.74 harris41 2488: There are two characteristics associated with the running of B<lond>,
2489: PROCESS MANAGEMENT (starting, stopping, handling child processes)
2490: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
2491: subscriptions, etc). These are described in two large
2492: sections below.
2493:
2494: B<PROCESS MANAGEMENT>
2495:
1.61 harris41 2496: Preforker - server who forks first. Runs as a daemon. HUPs.
2497: Uses IDEA encryption
2498:
1.74 harris41 2499: B<lond> forks off children processes that correspond to the other servers
2500: in the network. Management of these processes can be done at the
2501: parent process level or the child process level.
2502:
2503: B<logs/lond.log> is the location of log messages.
2504:
2505: The process management is now explained in terms of linux shell commands,
2506: subroutines internal to this code, and signal assignments:
2507:
2508: =over 4
2509:
2510: =item *
2511:
2512: PID is stored in B<logs/lond.pid>
2513:
2514: This is the process id number of the parent B<lond> process.
2515:
2516: =item *
2517:
2518: SIGTERM and SIGINT
2519:
2520: Parent signal assignment:
2521: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
2522:
2523: Child signal assignment:
2524: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
2525: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
2526: to restart a new child.)
2527:
2528: Command-line invocations:
2529: B<kill> B<-s> SIGTERM I<PID>
2530: B<kill> B<-s> SIGINT I<PID>
2531:
2532: Subroutine B<HUNTSMAN>:
2533: This is only invoked for the B<lond> parent I<PID>.
2534: This kills all the children, and then the parent.
2535: The B<lonc.pid> file is cleared.
2536:
2537: =item *
2538:
2539: SIGHUP
2540:
2541: Current bug:
2542: This signal can only be processed the first time
2543: on the parent process. Subsequent SIGHUP signals
2544: have no effect.
2545:
2546: Parent signal assignment:
2547: $SIG{HUP} = \&HUPSMAN;
2548:
2549: Child signal assignment:
2550: none (nothing happens)
2551:
2552: Command-line invocations:
2553: B<kill> B<-s> SIGHUP I<PID>
2554:
2555: Subroutine B<HUPSMAN>:
2556: This is only invoked for the B<lond> parent I<PID>,
2557: This kills all the children, and then the parent.
2558: The B<lond.pid> file is cleared.
2559:
2560: =item *
2561:
2562: SIGUSR1
2563:
2564: Parent signal assignment:
2565: $SIG{USR1} = \&USRMAN;
2566:
2567: Child signal assignment:
2568: $SIG{USR1}= \&logstatus;
2569:
2570: Command-line invocations:
2571: B<kill> B<-s> SIGUSR1 I<PID>
2572:
2573: Subroutine B<USRMAN>:
2574: When invoked for the B<lond> parent I<PID>,
2575: SIGUSR1 is sent to all the children, and the status of
2576: each connection is logged.
1.144 foxr 2577:
2578: =item *
2579:
2580: SIGUSR2
2581:
2582: Parent Signal assignment:
2583: $SIG{USR2} = \&UpdateHosts
2584:
2585: Child signal assignment:
2586: NONE
2587:
1.74 harris41 2588:
2589: =item *
2590:
2591: SIGCHLD
2592:
2593: Parent signal assignment:
2594: $SIG{CHLD} = \&REAPER;
2595:
2596: Child signal assignment:
2597: none
2598:
2599: Command-line invocations:
2600: B<kill> B<-s> SIGCHLD I<PID>
2601:
2602: Subroutine B<REAPER>:
2603: This is only invoked for the B<lond> parent I<PID>.
2604: Information pertaining to the child is removed.
2605: The socket port is cleaned up.
2606:
2607: =back
2608:
2609: B<SERVER-SIDE ACTIVITIES>
2610:
2611: Server-side information can be accepted in an encrypted or non-encrypted
2612: method.
2613:
2614: =over 4
2615:
2616: =item ping
2617:
2618: Query a client in the hosts.tab table; "Are you there?"
2619:
2620: =item pong
2621:
2622: Respond to a ping query.
2623:
2624: =item ekey
2625:
2626: Read in encrypted key, make cipher. Respond with a buildkey.
2627:
2628: =item load
2629:
2630: Respond with CPU load based on a computation upon /proc/loadavg.
2631:
2632: =item currentauth
2633:
2634: Reply with current authentication information (only over an
2635: encrypted channel).
2636:
2637: =item auth
2638:
2639: Only over an encrypted channel, reply as to whether a user's
2640: authentication information can be validated.
2641:
2642: =item passwd
2643:
2644: Allow for a password to be set.
2645:
2646: =item makeuser
2647:
2648: Make a user.
2649:
2650: =item passwd
2651:
2652: Allow for authentication mechanism and password to be changed.
2653:
2654: =item home
1.61 harris41 2655:
1.74 harris41 2656: Respond to a question "are you the home for a given user?"
2657:
2658: =item update
2659:
2660: Update contents of a subscribed resource.
2661:
2662: =item unsubscribe
2663:
2664: The server is unsubscribing from a resource.
2665:
2666: =item subscribe
2667:
2668: The server is subscribing to a resource.
2669:
2670: =item log
2671:
2672: Place in B<logs/lond.log>
2673:
2674: =item put
2675:
2676: stores hash in namespace
2677:
2678: =item rolesput
2679:
2680: put a role into a user's environment
2681:
2682: =item get
2683:
2684: returns hash with keys from array
2685: reference filled in from namespace
2686:
2687: =item eget
2688:
2689: returns hash with keys from array
2690: reference filled in from namesp (encrypts the return communication)
2691:
2692: =item rolesget
2693:
2694: get a role from a user's environment
2695:
2696: =item del
2697:
2698: deletes keys out of array from namespace
2699:
2700: =item keys
2701:
2702: returns namespace keys
2703:
2704: =item dump
2705:
2706: dumps the complete (or key matching regexp) namespace into a hash
2707:
2708: =item store
2709:
2710: stores hash permanently
2711: for this url; hashref needs to be given and should be a \%hashname; the
2712: remaining args aren't required and if they aren't passed or are '' they will
2713: be derived from the ENV
2714:
2715: =item restore
2716:
2717: returns a hash for a given url
2718:
2719: =item querysend
2720:
2721: Tells client about the lonsql process that has been launched in response
2722: to a sent query.
2723:
2724: =item queryreply
2725:
2726: Accept information from lonsql and make appropriate storage in temporary
2727: file space.
2728:
2729: =item idput
2730:
2731: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
2732: for each student, defined perhaps by the institutional Registrar.)
2733:
2734: =item idget
2735:
2736: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
2737: for each student, defined perhaps by the institutional Registrar.)
2738:
2739: =item tmpput
2740:
2741: Accept and store information in temporary space.
2742:
2743: =item tmpget
2744:
2745: Send along temporarily stored information.
2746:
2747: =item ls
2748:
2749: List part of a user's directory.
2750:
1.135 foxr 2751: =item pushtable
2752:
2753: Pushes a file in /home/httpd/lonTab directory. Currently limited to:
2754: hosts.tab and domain.tab. The old file is copied to *.tab.backup but
2755: must be restored manually in case of a problem with the new table file.
2756: pushtable requires that the request be encrypted and validated via
2757: ValidateManager. The form of the command is:
2758: enc:pushtable tablename <tablecontents> \n
2759: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
2760: cleartext newline.
2761:
1.74 harris41 2762: =item Hanging up (exit or init)
2763:
2764: What to do when a client tells the server that they (the client)
2765: are leaving the network.
2766:
2767: =item unknown command
2768:
2769: If B<lond> is sent an unknown command (not in the list above),
2770: it replys to the client "unknown_cmd".
1.135 foxr 2771:
1.74 harris41 2772:
2773: =item UNKNOWN CLIENT
2774:
2775: If the anti-spoofing algorithm cannot verify the client,
2776: the client is rejected (with a "refused" message sent
2777: to the client, and the connection is closed.
2778:
2779: =back
1.61 harris41 2780:
2781: =head1 PREREQUISITES
2782:
2783: IO::Socket
2784: IO::File
2785: Apache::File
2786: Symbol
2787: POSIX
2788: Crypt::IDEA
2789: LWP::UserAgent()
2790: GDBM_File
2791: Authen::Krb4
1.91 albertel 2792: Authen::Krb5
1.61 harris41 2793:
2794: =head1 COREQUISITES
2795:
2796: =head1 OSNAMES
2797:
2798: linux
2799:
2800: =head1 SCRIPT CATEGORIES
2801:
2802: Server/Process
2803:
2804: =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