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