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