Annotation of loncom/lond, revision 1.60
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 ! www 4: #
! 5: # $Id: gplheader.pl,v 1.1 2001/11/29 18:19:27 www 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: #
1.1 albertel 29: # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,
1.2 www 30: # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,
1.6 www 31: # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
1.11 www 32: # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
1.12 harris41 33: # 03/07,05/31 Gerd Kortemeyer
1.13 www 34: # 06/26 Scott Harrison
1.20 www 35: # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
1.25 www 36: # 12/05 Scott Harrison
1.34 www 37: # 12/05,12/13,12/29 Gerd Kortemeyer
1.36 www 38: # Jan 01 Scott Harrison
39: # 02/12 Gerd Kortemeyer
1.37 harris41 40: # 03/15 Scott Harrison
1.41 www 41: # 03/24 Gerd Kortemeyer
1.47 www 42: # 04/02 Scott Harrison
1.51 www 43: # 05/11,05/28,08/30 Gerd Kortemeyer
1.56 harris41 44: # 9/30,10/22,11/13,11/15,11/16 Scott Harrison
1.59 www 45: # 11/26,11/27 Gerd Kortemeyer
1.13 www 46: #
1.54 harris41 47: ###
48:
1.1 albertel 49: # based on "Perl Cookbook" ISBN 1-56592-243-3
50: # preforker - server who forks first
51: # runs as a daemon
52: # HUPs
53: # uses IDEA encryption
54:
55: use IO::Socket;
56: use IO::File;
57: use Apache::File;
58: use Symbol;
59: use POSIX;
60: use Crypt::IDEA;
61: use LWP::UserAgent();
1.3 www 62: use GDBM_File;
63: use Authen::Krb4;
1.49 albertel 64: use lib '/home/httpd/lib/perl/';
65: use localauth;
1.1 albertel 66:
1.57 www 67: my $status='';
68: my $lastlog='';
69:
1.23 harris41 70: # grabs exception and records it to log before exiting
71: sub catchexception {
1.27 albertel 72: my ($error)=@_;
1.25 www 73: $SIG{'QUIT'}='DEFAULT';
74: $SIG{__DIE__}='DEFAULT';
1.23 harris41 75: &logthis("<font color=red>CRITICAL: "
76: ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
1.27 albertel 77: ."a crash with this error msg->[$error]</font>");
1.57 www 78: &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27 albertel 79: if ($client) { print $client "error: $error\n"; }
1.59 www 80: $server->close();
1.27 albertel 81: die($error);
1.23 harris41 82: }
83:
1.22 harris41 84: # -------------------------------- Set signal handlers to record abnormal exits
85:
86: $SIG{'QUIT'}=\&catchexception;
87: $SIG{__DIE__}=\&catchexception;
88:
1.1 albertel 89: # ------------------------------------ Read httpd access.conf and get variables
90:
1.29 harris41 91: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
1.1 albertel 92:
93: while ($configline=<CONFIG>) {
94: if ($configline =~ /PerlSetVar/) {
95: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.7 www 96: chomp($varvalue);
1.1 albertel 97: $perlvar{$varname}=$varvalue;
98: }
99: }
100: close(CONFIG);
1.19 www 101:
1.35 harris41 102: # ----------------------------- Make sure this process is running from user=www
103: my $wwwid=getpwnam('www');
104: if ($wwwid!=$<) {
105: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
106: $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
1.37 harris41 107: system("echo 'User ID mismatch. lond must be run as user www.' |\
1.35 harris41 108: mailto $emailto -s '$subj' > /dev/null");
109: exit 1;
110: }
111:
1.19 www 112: # --------------------------------------------- Check if other instance running
113:
114: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
115:
116: if (-e $pidfile) {
117: my $lfh=IO::File->new("$pidfile");
118: my $pide=<$lfh>;
119: chomp($pide);
1.29 harris41 120: if (kill 0 => $pide) { die "already running"; }
1.19 www 121: }
1.1 albertel 122:
123: $PREFORK=4; # number of children to maintain, at least four spare
124:
125: # ------------------------------------------------------------- Read hosts file
126:
1.29 harris41 127: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
1.1 albertel 128:
129: while ($configline=<CONFIG>) {
130: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
131: chomp($ip);
132: $hostid{$ip}=$id;
133: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
134: $PREFORK++;
135: }
136: close(CONFIG);
137:
138: # establish SERVER socket, bind and listen.
139: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
140: Type => SOCK_STREAM,
141: Proto => 'tcp',
142: Reuse => 1,
143: Listen => 10 )
1.29 harris41 144: or die "making socket: $@\n";
1.1 albertel 145:
146: # --------------------------------------------------------- Do global variables
147:
148: # global variables
149:
150: $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should
151: # process
152: %children = (); # keys are current child process IDs
153: $children = 0; # current number of children
154:
155: sub REAPER { # takes care of dead children
156: $SIG{CHLD} = \&REAPER;
157: my $pid = wait;
158: $children --;
159: &logthis("Child $pid died");
160: delete $children{$pid};
161: }
162:
163: sub HUNTSMAN { # signal handler for SIGINT
164: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
165: kill 'INT' => keys %children;
1.59 www 166: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1 albertel 167: my $execdir=$perlvar{'lonDaemons'};
168: unlink("$execdir/logs/lond.pid");
1.9 www 169: &logthis("<font color=red>CRITICAL: Shutting down</font>");
1.1 albertel 170: exit; # clean up with dignity
171: }
172:
173: sub HUPSMAN { # signal handler for SIGHUP
174: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
175: kill 'INT' => keys %children;
1.59 www 176: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.9 www 177: &logthis("<font color=red>CRITICAL: Restarting</font>");
1.30 harris41 178: unlink("$execdir/logs/lond.pid");
1.1 albertel 179: my $execdir=$perlvar{'lonDaemons'};
180: exec("$execdir/lond"); # here we go again
181: }
182:
1.57 www 183: sub checkchildren {
184: &initnewstatus();
185: &logstatus();
186: &logthis('Going to check on the children');
187: map {
188: sleep 1;
189: unless (kill 'USR1' => $_) {
190: &logthis ('Child '.$_.' is dead');
191: &logstatus($$.' is dead');
192: }
193: } sort keys %children;
194: }
195:
1.1 albertel 196: # --------------------------------------------------------------------- Logging
197:
198: sub logthis {
199: my $message=shift;
200: my $execdir=$perlvar{'lonDaemons'};
201: my $fh=IO::File->new(">>$execdir/logs/lond.log");
202: my $now=time;
203: my $local=localtime($now);
1.58 www 204: $lastlog=$local.': '.$message;
1.1 albertel 205: print $fh "$local ($$): $message\n";
206: }
207:
1.57 www 208: # ------------------------------------------------------------------ Log status
209:
210: sub logstatus {
211: my $docdir=$perlvar{'lonDocRoot'};
212: my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
213: print $fh $$."\t".$status."\t".$lastlog."\n";
214: }
215:
216: sub initnewstatus {
217: my $docdir=$perlvar{'lonDocRoot'};
218: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
219: my $now=time;
220: my $local=localtime($now);
221: print $fh "LOND status $local - parent $$\n\n";
222: }
223:
224: # -------------------------------------------------------------- Status setting
225:
226: sub status {
227: my $what=shift;
228: my $now=time;
229: my $local=localtime($now);
230: $status=$local.': '.$what;
231: }
1.11 www 232:
233: # -------------------------------------------------------- Escape Special Chars
234:
235: sub escape {
236: my $str=shift;
237: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
238: return $str;
239: }
240:
241: # ----------------------------------------------------- Un-Escape Special Chars
242:
243: sub unescape {
244: my $str=shift;
245: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
246: return $str;
247: }
248:
1.1 albertel 249: # ----------------------------------------------------------- Send USR1 to lonc
250:
251: sub reconlonc {
252: my $peerfile=shift;
253: &logthis("Trying to reconnect for $peerfile");
254: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
255: if (my $fh=IO::File->new("$loncfile")) {
256: my $loncpid=<$fh>;
257: chomp($loncpid);
258: if (kill 0 => $loncpid) {
259: &logthis("lonc at pid $loncpid responding, sending USR1");
260: kill USR1 => $loncpid;
261: sleep 1;
262: if (-e "$peerfile") { return; }
263: &logthis("$peerfile still not there, give it another try");
264: sleep 5;
265: if (-e "$peerfile") { return; }
1.9 www 266: &logthis(
267: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1 albertel 268: } else {
1.9 www 269: &logthis(
270: "<font color=red>CRITICAL: "
271: ."lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 272: }
273: } else {
1.9 www 274: &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
1.1 albertel 275: }
276: }
277:
278: # -------------------------------------------------- Non-critical communication
1.11 www 279:
1.1 albertel 280: sub subreply {
281: my ($cmd,$server)=@_;
282: my $peerfile="$perlvar{'lonSockDir'}/$server";
283: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
284: Type => SOCK_STREAM,
285: Timeout => 10)
286: or return "con_lost";
287: print $sclient "$cmd\n";
288: my $answer=<$sclient>;
289: chomp($answer);
290: if (!$answer) { $answer="con_lost"; }
291: return $answer;
292: }
293:
294: sub reply {
295: my ($cmd,$server)=@_;
296: my $answer;
297: if ($server ne $perlvar{'lonHostID'}) {
298: $answer=subreply($cmd,$server);
299: if ($answer eq 'con_lost') {
300: $answer=subreply("ping",$server);
301: if ($answer ne $server) {
302: &reconlonc("$perlvar{'lonSockDir'}/$server");
303: }
304: $answer=subreply($cmd,$server);
305: }
306: } else {
307: $answer='self_reply';
308: }
309: return $answer;
310: }
311:
1.13 www 312: # -------------------------------------------------------------- Talk to lonsql
313:
1.12 harris41 314: sub sqlreply {
315: my ($cmd)=@_;
316: my $answer=subsqlreply($cmd);
317: if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }
318: return $answer;
319: }
320:
321: sub subsqlreply {
322: my ($cmd)=@_;
323: my $unixsock="mysqlsock";
324: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
325: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
326: Type => SOCK_STREAM,
327: Timeout => 10)
328: or return "con_lost";
329: print $sclient "$cmd\n";
330: my $answer=<$sclient>;
331: chomp($answer);
332: if (!$answer) { $answer="con_lost"; }
333: return $answer;
334: }
335:
1.1 albertel 336: # -------------------------------------------- Return path to profile directory
1.11 www 337:
1.1 albertel 338: sub propath {
339: my ($udom,$uname)=@_;
340: $udom=~s/\W//g;
341: $uname=~s/\W//g;
1.16 www 342: my $subdir=$uname.'__';
1.1 albertel 343: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
344: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
345: return $proname;
346: }
347:
348: # --------------------------------------- Is this the home server of an author?
1.11 www 349:
1.1 albertel 350: sub ishome {
351: my $author=shift;
352: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
353: my ($udom,$uname)=split(/\//,$author);
354: my $proname=propath($udom,$uname);
355: if (-e $proname) {
356: return 'owner';
357: } else {
358: return 'not_owner';
359: }
360: }
361:
362: # ======================================================= Continue main program
363: # ---------------------------------------------------- Fork once and dissociate
364:
365: $fpid=fork;
366: exit if $fpid;
1.29 harris41 367: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 368:
1.29 harris41 369: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 370:
371: # ------------------------------------------------------- Write our PID on disk
372:
373: $execdir=$perlvar{'lonDaemons'};
374: open (PIDSAVE,">$execdir/logs/lond.pid");
375: print PIDSAVE "$$\n";
376: close(PIDSAVE);
1.9 www 377: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
1.57 www 378: &status('Starting');
1.1 albertel 379:
380: # ------------------------------------------------------- Now we are on our own
381:
382: # Fork off our children.
383: for (1 .. $PREFORK) {
384: make_new_child();
385: }
386:
387: # ----------------------------------------------------- Install signal handlers
388:
1.57 www 389: &status('Forked children');
390:
1.1 albertel 391: $SIG{CHLD} = \&REAPER;
392: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
393: $SIG{HUP} = \&HUPSMAN;
1.57 www 394: $SIG{USR1} = \&checkchildren;
1.1 albertel 395:
396: # And maintain the population.
397: while (1) {
1.57 www 398: &status('Sleeping');
1.1 albertel 399: sleep; # wait for a signal (i.e., child's death)
1.57 www 400: &logthis('Woke up');
401: &status('Woke up');
1.1 albertel 402: for ($i = $children; $i < $PREFORK; $i++) {
403: make_new_child(); # top up the child pool
404: }
405: }
406:
407: sub make_new_child {
408: my $pid;
409: my $cipher;
410: my $sigset;
411: &logthis("Attempting to start child");
412: # block signal for fork
413: $sigset = POSIX::SigSet->new(SIGINT);
414: sigprocmask(SIG_BLOCK, $sigset)
1.29 harris41 415: or die "Can't block SIGINT for fork: $!\n";
1.1 albertel 416:
1.29 harris41 417: die "fork: $!" unless defined ($pid = fork);
1.1 albertel 418:
419: if ($pid) {
420: # Parent records the child's birth and returns.
421: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 422: or die "Can't unblock SIGINT for fork: $!\n";
1.1 albertel 423: $children{$pid} = 1;
424: $children++;
1.57 www 425: &status('Started child '.$pid);
1.1 albertel 426: return;
427: } else {
428: # Child can *not* return from this subroutine.
429: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
1.57 www 430: $SIG{USR1}= \&logstatus;
431: $lastlog='Forked ';
432: $status='Forked';
433:
1.1 albertel 434: # unblock signals
435: sigprocmask(SIG_UNBLOCK, $sigset)
1.29 harris41 436: or die "Can't unblock SIGINT for fork: $!\n";
1.13 www 437:
438: $tmpsnum=0;
1.1 albertel 439:
440: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
441: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
1.57 www 442: &status('Idle, waiting for connection');
1.1 albertel 443: $client = $server->accept() or last;
1.57 www 444: &status('Accepted connection');
1.1 albertel 445: # =============================================================================
446: # do something with the connection
447: # -----------------------------------------------------------------------------
1.2 www 448: # see if we know client and check for spoof IP by challenge
1.1 albertel 449: my $caller=getpeername($client);
450: my ($port,$iaddr)=unpack_sockaddr_in($caller);
451: my $clientip=inet_ntoa($iaddr);
452: my $clientrec=($hostid{$clientip} ne undef);
1.9 www 453: &logthis(
1.51 www 454: "<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>"
455: );
1.57 www 456: &status("Connecting $clientip ($hostid{$clientip})");
1.2 www 457: my $clientok;
1.1 albertel 458: if ($clientrec) {
1.57 www 459: &status("Waiting for init from $clientip ($hostid{$clientip})");
1.2 www 460: my $remotereq=<$client>;
461: $remotereq=~s/\W//g;
462: if ($remotereq eq 'init') {
463: my $challenge="$$".time;
464: print $client "$challenge\n";
1.57 www 465: &status(
466: "Waiting for challenge reply from $clientip ($hostid{$clientip})");
1.2 www 467: $remotereq=<$client>;
468: $remotereq=~s/\W//g;
469: if ($challenge eq $remotereq) {
470: $clientok=1;
471: print $client "ok\n";
472: } else {
1.9 www 473: &logthis(
474: "<font color=blue>WARNING: $clientip did not reply challenge</font>");
1.57 www 475: &status('No challenge reply '.$clientip);
1.2 www 476: }
477: } else {
1.9 www 478: &logthis(
479: "<font color=blue>WARNING: "
480: ."$clientip failed to initialize: >$remotereq< </font>");
1.57 www 481: &status('No init '.$clientip);
1.2 www 482: }
483: } else {
1.9 www 484: &logthis(
485: "<font color=blue>WARNING: Unknown client $clientip</font>");
1.57 www 486: &status('Hung up on '.$clientip);
1.2 www 487: }
488: if ($clientok) {
1.1 albertel 489: # ---------------- New known client connecting, could mean machine online again
490: &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
1.9 www 491: &logthis(
492: "<font color=green>Established connection: $hostid{$clientip}</font>");
1.58 www 493: &status('Will listen to '.$hostid{$clientip});
1.1 albertel 494: # ------------------------------------------------------------ Process requests
495: while (my $userinput=<$client>) {
496: chomp($userinput);
1.57 www 497: &status('Processing '.$hostid{$clientip}.': '.$userinput);
1.1 albertel 498: my $wasenc=0;
499: # ------------------------------------------------------------ See if encrypted
500: if ($userinput =~ /^enc/) {
501: if ($cipher) {
502: my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
503: $userinput='';
504: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
505: $userinput.=
506: $cipher->decrypt(
507: pack("H16",substr($encinput,$encidx,16))
508: );
509: }
510: $userinput=substr($userinput,0,$cmdlength);
511: $wasenc=1;
512: }
513: }
514: # ------------------------------------------------------------- Normal commands
515: # ------------------------------------------------------------------------ ping
516: if ($userinput =~ /^ping/) {
517: print $client "$perlvar{'lonHostID'}\n";
518: # ------------------------------------------------------------------------ pong
519: } elsif ($userinput =~ /^pong/) {
520: $reply=reply("ping",$hostid{$clientip});
521: print $client "$perlvar{'lonHostID'}:$reply\n";
522: # ------------------------------------------------------------------------ ekey
523: } elsif ($userinput =~ /^ekey/) {
524: my $buildkey=time.$$.int(rand 100000);
525: $buildkey=~tr/1-6/A-F/;
526: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
527: my $key=$perlvar{'lonHostID'}.$hostid{$clientip};
528: $key=~tr/a-z/A-Z/;
529: $key=~tr/G-P/0-9/;
530: $key=~tr/Q-Z/0-9/;
531: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
532: $key=substr($key,0,32);
533: my $cipherkey=pack("H32",$key);
534: $cipher=new IDEA $cipherkey;
535: print $client "$buildkey\n";
536: # ------------------------------------------------------------------------ load
537: } elsif ($userinput =~ /^load/) {
538: my $loadavg;
539: {
540: my $loadfile=IO::File->new('/proc/loadavg');
541: $loadavg=<$loadfile>;
542: }
543: $loadavg =~ s/\s.*//g;
544: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
545: print $client "$loadpercent\n";
1.54 harris41 546: # ----------------------------------------------------------------- currentauth
547: } elsif ($userinput =~ /^currentauth/) {
548: if ($wasenc==1) {
549: my ($cmd,$udom,$uname)=split(/:/,$userinput);
550: my $proname=propath($udom,$uname);
551: my $passfilename="$proname/passwd";
552: if (-e $passfilename) {
553: my $pf = IO::File->new($passfilename);
554: my $realpasswd=<$pf>;
555: chomp($realpasswd);
556: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
557: my $availablecontent='';
558: if ($howpwd eq 'krb4') {
559: $availablecontent=$contentpwd;
560: }
561: print $client "$howpwd:$availablecontent\n";
562: } else {
563: print $client "unknown_user\n";
564: }
565: } else {
566: print $client "refused\n";
567: }
1.1 albertel 568: # ------------------------------------------------------------------------ auth
569: } elsif ($userinput =~ /^auth/) {
570: if ($wasenc==1) {
571: my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
572: chomp($upass);
1.11 www 573: $upass=unescape($upass);
1.1 albertel 574: my $proname=propath($udom,$uname);
575: my $passfilename="$proname/passwd";
576: if (-e $passfilename) {
577: my $pf = IO::File->new($passfilename);
578: my $realpasswd=<$pf>;
579: chomp($realpasswd);
1.2 www 580: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
581: my $pwdcorrect=0;
582: if ($howpwd eq 'internal') {
583: $pwdcorrect=
584: (crypt($upass,$contentpwd) eq $contentpwd);
585: } elsif ($howpwd eq 'unix') {
586: $contentpwd=(getpwnam($uname))[1];
1.52 harris41 587: my $pwauth_path="/usr/local/sbin/pwauth";
588: unless ($contentpwd eq 'x') {
589: $pwdcorrect=
590: (crypt($upass,$contentpwd) eq $contentpwd);
591: }
592: elsif (-e $pwauth_path) {
593: open PWAUTH, "|$pwauth_path" or
594: die "Cannot invoke authentication";
595: print PWAUTH "$uname\n$upass\n";
596: close PWAUTH;
597: $pwdcorrect=!$?;
598: }
1.3 www 599: } elsif ($howpwd eq 'krb4') {
600: $pwdcorrect=(
601: Authen::Krb4::get_pw_in_tkt($uname,"",
602: $contentpwd,'krbtgt',$contentpwd,1,
603: $upass) == 0);
1.50 albertel 604: } elsif ($howpwd eq 'localauth') {
1.49 albertel 605: $pwdcorrect=&localauth::localauth($uname,$upass,
606: $contentpwd);
607: }
1.2 www 608: if ($pwdcorrect) {
1.1 albertel 609: print $client "authorized\n";
610: } else {
611: print $client "non_authorized\n";
612: }
613: } else {
614: print $client "unknown_user\n";
615: }
616: } else {
617: print $client "refused\n";
618: }
619: # ---------------------------------------------------------------------- passwd
620: } elsif ($userinput =~ /^passwd/) {
621: if ($wasenc==1) {
622: my
623: ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
624: chomp($npass);
1.32 www 625: $upass=&unescape($upass);
626: $npass=&unescape($npass);
1.1 albertel 627: my $proname=propath($udom,$uname);
628: my $passfilename="$proname/passwd";
629: if (-e $passfilename) {
630: my $realpasswd;
631: { my $pf = IO::File->new($passfilename);
632: $realpasswd=<$pf>; }
633: chomp($realpasswd);
1.2 www 634: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
635: if ($howpwd eq 'internal') {
636: if (crypt($upass,$contentpwd) eq $contentpwd) {
637: my $salt=time;
638: $salt=substr($salt,6,2);
639: my $ncpass=crypt($npass,$salt);
1.1 albertel 640: { my $pf = IO::File->new(">$passfilename");
1.31 www 641: print $pf "internal:$ncpass\n"; }
1.1 albertel 642: print $client "ok\n";
1.2 www 643: } else {
644: print $client "non_authorized\n";
645: }
1.1 albertel 646: } else {
1.2 www 647: print $client "auth_mode_error\n";
1.1 albertel 648: }
649: } else {
650: print $client "unknown_user\n";
1.31 www 651: }
652: } else {
653: print $client "refused\n";
654: }
655: # -------------------------------------------------------------------- makeuser
656: } elsif ($userinput =~ /^makeuser/) {
1.56 harris41 657: my $oldumask=umask(0077);
1.31 www 658: if ($wasenc==1) {
659: my
660: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
661: chomp($npass);
1.32 www 662: $npass=&unescape($npass);
1.31 www 663: my $proname=propath($udom,$uname);
664: my $passfilename="$proname/passwd";
665: if (-e $passfilename) {
666: print $client "already_exists\n";
667: } elsif ($udom ne $perlvar{'lonDefDomain'}) {
668: print $client "not_right_domain\n";
669: } else {
670: @fpparts=split(/\//,$proname);
671: $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
672: $fperror='';
673: for ($i=3;$i<=$#fpparts;$i++) {
674: $fpnow.='/'.$fpparts[$i];
675: unless (-e $fpnow) {
676: unless (mkdir($fpnow,0777)) {
677: $fperror="error:$!\n";
678: }
679: }
680: }
681: unless ($fperror) {
1.34 www 682: if ($umode eq 'krb4') {
1.31 www 683: {
684: my $pf = IO::File->new(">$passfilename");
1.33 www 685: print $pf "krb4:$npass\n";
1.31 www 686: }
687: print $client "ok\n";
688: } elsif ($umode eq 'internal') {
689: my $salt=time;
690: $salt=substr($salt,6,2);
691: my $ncpass=crypt($npass,$salt);
692: {
693: my $pf = IO::File->new(">$passfilename");
694: print $pf "internal:$ncpass\n";
1.50 albertel 695: }
1.31 www 696: print $client "ok\n";
1.50 albertel 697: } elsif ($umode eq 'localauth') {
698: {
699: my $pf = IO::File->new(">$passfilename");
700: print $pf "localauth:$npass\n";
701: }
702: print $client "ok\n";
1.53 harris41 703: } elsif ($umode eq 'unix') {
704: {
705: my $execpath="$perlvar{'lonDaemons'}/".
706: "lcuseradd";
1.54 harris41 707: {
708: my $se = IO::File->new("|$execpath");
709: print $se "$uname\n";
710: print $se "$npass\n";
711: print $se "$npass\n";
712: }
1.53 harris41 713: my $pf = IO::File->new(">$passfilename");
714: print $pf "unix:\n";
715: }
1.54 harris41 716: print $client "ok\n";
1.53 harris41 717: } elsif ($umode eq 'none') {
1.31 www 718: {
719: my $pf = IO::File->new(">$passfilename");
720: print $pf "none:\n";
721: }
722: print $client "ok\n";
723: } else {
724: print $client "auth_mode_error\n";
725: }
726: } else {
727: print $client "$fperror\n";
728: }
1.55 harris41 729: }
730: } else {
731: print $client "refused\n";
732: }
1.56 harris41 733: umask($oldumask);
1.55 harris41 734: # -------------------------------------------------------------- changeuserauth
735: } elsif ($userinput =~ /^changeuserauth/) {
736: if ($wasenc==1) {
737: my
738: ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
739: chomp($npass);
740: $npass=&unescape($npass);
741: my $proname=propath($udom,$uname);
742: my $passfilename="$proname/passwd";
743: if ($udom ne $perlvar{'lonDefDomain'}) {
744: print $client "not_right_domain\n";
745: } else {
746: if ($umode eq 'krb4') {
747: {
748: my $pf = IO::File->new(">$passfilename");
749: print $pf "krb4:$npass\n";
750: }
751: print $client "ok\n";
752: } elsif ($umode eq 'internal') {
753: my $salt=time;
754: $salt=substr($salt,6,2);
755: my $ncpass=crypt($npass,$salt);
756: {
757: my $pf = IO::File->new(">$passfilename");
758: print $pf "internal:$ncpass\n";
759: }
760: print $client "ok\n";
761: } elsif ($umode eq 'localauth') {
762: {
763: my $pf = IO::File->new(">$passfilename");
764: print $pf "localauth:$npass\n";
765: }
766: print $client "ok\n";
767: } elsif ($umode eq 'unix') {
768: {
769: my $execpath="$perlvar{'lonDaemons'}/".
770: "lcuseradd";
771: {
772: my $se = IO::File->new("|$execpath");
773: print $se "$uname\n";
774: print $se "$npass\n";
775: print $se "$npass\n";
776: }
777: my $pf = IO::File->new(">$passfilename");
778: print $pf "unix:\n";
779: }
780: print $client "ok\n";
781: } elsif ($umode eq 'none') {
782: {
783: my $pf = IO::File->new(">$passfilename");
784: print $pf "none:\n";
785: }
786: print $client "ok\n";
787: } else {
788: print $client "auth_mode_error\n";
789: }
1.1 albertel 790: }
791: } else {
792: print $client "refused\n";
793: }
794: # ------------------------------------------------------------------------ home
795: } elsif ($userinput =~ /^home/) {
796: my ($cmd,$udom,$uname)=split(/:/,$userinput);
797: chomp($uname);
798: my $proname=propath($udom,$uname);
799: if (-e $proname) {
800: print $client "found\n";
801: } else {
802: print $client "not_found\n";
803: }
804: # ---------------------------------------------------------------------- update
805: } elsif ($userinput =~ /^update/) {
806: my ($cmd,$fname)=split(/:/,$userinput);
807: my $ownership=ishome($fname);
808: if ($ownership eq 'not_owner') {
809: if (-e $fname) {
810: my ($dev,$ino,$mode,$nlink,
811: $uid,$gid,$rdev,$size,
812: $atime,$mtime,$ctime,
813: $blksize,$blocks)=stat($fname);
814: $now=time;
815: $since=$now-$atime;
816: if ($since>$perlvar{'lonExpire'}) {
817: $reply=
818: reply("unsub:$fname","$hostid{$clientip}");
819: unlink("$fname");
820: } else {
821: my $transname="$fname.in.transfer";
822: my $remoteurl=
823: reply("sub:$fname","$hostid{$clientip}");
824: my $response;
825: {
826: my $ua=new LWP::UserAgent;
827: my $request=new HTTP::Request('GET',"$remoteurl");
828: $response=$ua->request($request,$transname);
829: }
830: if ($response->is_error()) {
1.24 albertel 831: unlink($transname);
1.1 albertel 832: my $message=$response->status_line;
833: &logthis(
834: "LWP GET: $message for $fname ($remoteurl)");
835: } else {
1.14 www 836: if ($remoteurl!~/\.meta$/) {
1.28 www 837: my $ua=new LWP::UserAgent;
1.14 www 838: my $mrequest=
839: new HTTP::Request('GET',$remoteurl.'.meta');
840: my $mresponse=
841: $ua->request($mrequest,$fname.'.meta');
842: if ($mresponse->is_error()) {
843: unlink($fname.'.meta');
844: }
845: }
1.1 albertel 846: rename($transname,$fname);
847: }
848: }
849: print $client "ok\n";
850: } else {
851: print $client "not_found\n";
852: }
853: } else {
854: print $client "rejected\n";
855: }
856: # ----------------------------------------------------------------- unsubscribe
857: } elsif ($userinput =~ /^unsub/) {
858: my ($cmd,$fname)=split(/:/,$userinput);
859: if (-e $fname) {
860: if (unlink("$fname.$hostid{$clientip}")) {
861: print $client "ok\n";
862: } else {
863: print $client "not_subscribed\n";
864: }
865: } else {
866: print $client "not_found\n";
867: }
868: # ------------------------------------------------------------------- subscribe
869: } elsif ($userinput =~ /^sub/) {
870: my ($cmd,$fname)=split(/:/,$userinput);
871: my $ownership=ishome($fname);
872: if ($ownership eq 'owner') {
873: if (-e $fname) {
1.18 www 874: if (-d $fname) {
875: print $client "directory\n";
876: } else {
1.1 albertel 877: $now=time;
878: {
1.26 www 879: my $sh;
1.25 www 880: if ($sh=
881: IO::File->new(">$fname.$hostid{$clientip}")) {
882: print $sh "$clientip:$now\n";
883: }
1.1 albertel 884: }
1.42 www 885: unless ($fname=~/\.meta$/) {
886: unlink("$fname.meta.$hostid{$clientip}");
887: }
1.1 albertel 888: $fname=~s/\/home\/httpd\/html\/res/raw/;
889: $fname="http://$thisserver/".$fname;
890: print $client "$fname\n";
1.18 www 891: }
1.1 albertel 892: } else {
893: print $client "not_found\n";
894: }
895: } else {
896: print $client "rejected\n";
897: }
1.12 harris41 898: # ------------------------------------------------------------------------- log
899: } elsif ($userinput =~ /^log/) {
900: my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
901: chomp($what);
902: my $proname=propath($udom,$uname);
903: my $now=time;
904: {
905: my $hfh;
906: if ($hfh=IO::File->new(">>$proname/activity.log")) {
907: print $hfh "$now:$hostid{$clientip}:$what\n";
908: print $client "ok\n";
909: } else {
910: print $client "error:$!\n";
911: }
912: }
1.1 albertel 913: # ------------------------------------------------------------------------- put
914: } elsif ($userinput =~ /^put/) {
1.6 www 915: my ($cmd,$udom,$uname,$namespace,$what)
1.1 albertel 916: =split(/:/,$userinput);
1.8 www 917: $namespace=~s/\//\_/g;
1.6 www 918: $namespace=~s/\W//g;
919: if ($namespace ne 'roles') {
1.1 albertel 920: chomp($what);
921: my $proname=propath($udom,$uname);
922: my $now=time;
1.48 www 923: unless ($namespace=~/^nohist\_/) {
1.1 albertel 924: my $hfh;
925: if (
926: $hfh=IO::File->new(">>$proname/$namespace.hist")
927: ) { print $hfh "P:$now:$what\n"; }
928: }
929: my @pairs=split(/\&/,$what);
1.4 www 930: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 931: foreach $pair (@pairs) {
932: ($key,$value)=split(/=/,$pair);
933: $hash{$key}=$value;
934: }
1.4 www 935: if (untie(%hash)) {
1.1 albertel 936: print $client "ok\n";
937: } else {
938: print $client "error:$!\n";
939: }
940: } else {
941: print $client "error:$!\n";
942: }
1.6 www 943: } else {
944: print $client "refused\n";
945: }
946: # -------------------------------------------------------------------- rolesput
947: } elsif ($userinput =~ /^rolesput/) {
948: if ($wasenc==1) {
949: my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
950: =split(/:/,$userinput);
951: my $namespace='roles';
952: chomp($what);
953: my $proname=propath($udom,$uname);
954: my $now=time;
955: {
956: my $hfh;
957: if (
958: $hfh=IO::File->new(">>$proname/$namespace.hist")
959: ) {
960: print $hfh "P:$now:$exedom:$exeuser:$what\n";
961: }
962: }
963: my @pairs=split(/\&/,$what);
964: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
965: foreach $pair (@pairs) {
966: ($key,$value)=split(/=/,$pair);
967: $hash{$key}=$value;
968: }
969: if (untie(%hash)) {
970: print $client "ok\n";
971: } else {
972: print $client "error:$!\n";
973: }
974: } else {
975: print $client "error:$!\n";
976: }
977: } else {
978: print $client "refused\n";
979: }
1.1 albertel 980: # ------------------------------------------------------------------------- get
981: } elsif ($userinput =~ /^get/) {
982: my ($cmd,$udom,$uname,$namespace,$what)
983: =split(/:/,$userinput);
1.8 www 984: $namespace=~s/\//\_/g;
1.1 albertel 985: $namespace=~s/\W//g;
986: chomp($what);
987: my @queries=split(/\&/,$what);
988: my $proname=propath($udom,$uname);
989: my $qresult='';
1.20 www 990: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 991: for ($i=0;$i<=$#queries;$i++) {
992: $qresult.="$hash{$queries[$i]}&";
993: }
1.4 www 994: if (untie(%hash)) {
1.1 albertel 995: $qresult=~s/\&$//;
996: print $client "$qresult\n";
997: } else {
998: print $client "error:$!\n";
999: }
1000: } else {
1001: print $client "error:$!\n";
1002: }
1003: # ------------------------------------------------------------------------ eget
1004: } elsif ($userinput =~ /^eget/) {
1005: my ($cmd,$udom,$uname,$namespace,$what)
1006: =split(/:/,$userinput);
1.8 www 1007: $namespace=~s/\//\_/g;
1.1 albertel 1008: $namespace=~s/\W//g;
1009: chomp($what);
1010: my @queries=split(/\&/,$what);
1011: my $proname=propath($udom,$uname);
1012: my $qresult='';
1.20 www 1013: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1014: for ($i=0;$i<=$#queries;$i++) {
1015: $qresult.="$hash{$queries[$i]}&";
1016: }
1.4 www 1017: if (untie(%hash)) {
1.1 albertel 1018: $qresult=~s/\&$//;
1019: if ($cipher) {
1020: my $cmdlength=length($qresult);
1021: $qresult.=" ";
1022: my $encqresult='';
1023: for
1024: (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
1025: $encqresult.=
1026: unpack("H16",
1027: $cipher->encrypt(substr($qresult,$encidx,8)));
1028: }
1029: print $client "enc:$cmdlength:$encqresult\n";
1030: } else {
1031: print $client "error:no_key\n";
1032: }
1033: } else {
1034: print $client "error:$!\n";
1035: }
1036: } else {
1037: print $client "error:$!\n";
1038: }
1039: # ------------------------------------------------------------------------- del
1040: } elsif ($userinput =~ /^del/) {
1041: my ($cmd,$udom,$uname,$namespace,$what)
1042: =split(/:/,$userinput);
1.8 www 1043: $namespace=~s/\//\_/g;
1.1 albertel 1044: $namespace=~s/\W//g;
1045: chomp($what);
1046: my $proname=propath($udom,$uname);
1047: my $now=time;
1.48 www 1048: unless ($namespace=~/^nohist\_/) {
1.1 albertel 1049: my $hfh;
1050: if (
1051: $hfh=IO::File->new(">>$proname/$namespace.hist")
1052: ) { print $hfh "D:$now:$what\n"; }
1053: }
1054: my @keys=split(/\&/,$what);
1.4 www 1055: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 1056: foreach $key (@keys) {
1057: delete($hash{$key});
1058: }
1.4 www 1059: if (untie(%hash)) {
1.1 albertel 1060: print $client "ok\n";
1061: } else {
1062: print $client "error:$!\n";
1063: }
1064: } else {
1065: print $client "error:$!\n";
1066: }
1067: # ------------------------------------------------------------------------ keys
1068: } elsif ($userinput =~ /^keys/) {
1069: my ($cmd,$udom,$uname,$namespace)
1070: =split(/:/,$userinput);
1.8 www 1071: $namespace=~s/\//\_/g;
1.1 albertel 1072: $namespace=~s/\W//g;
1073: my $proname=propath($udom,$uname);
1074: my $qresult='';
1.20 www 1075: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1076: foreach $key (keys %hash) {
1077: $qresult.="$key&";
1078: }
1.4 www 1079: if (untie(%hash)) {
1.1 albertel 1080: $qresult=~s/\&$//;
1081: print $client "$qresult\n";
1082: } else {
1083: print $client "error:$!\n";
1084: }
1085: } else {
1086: print $client "error:$!\n";
1087: }
1088: # ------------------------------------------------------------------------ dump
1089: } elsif ($userinput =~ /^dump/) {
1090: my ($cmd,$udom,$uname,$namespace)
1091: =split(/:/,$userinput);
1.8 www 1092: $namespace=~s/\//\_/g;
1.1 albertel 1093: $namespace=~s/\W//g;
1094: my $proname=propath($udom,$uname);
1095: my $qresult='';
1.20 www 1096: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.1 albertel 1097: foreach $key (keys %hash) {
1098: $qresult.="$key=$hash{$key}&";
1.7 www 1099: }
1100: if (untie(%hash)) {
1101: $qresult=~s/\&$//;
1102: print $client "$qresult\n";
1103: } else {
1104: print $client "error:$!\n";
1105: }
1106: } else {
1107: print $client "error:$!\n";
1108: }
1109: # ----------------------------------------------------------------------- store
1110: } elsif ($userinput =~ /^store/) {
1111: my ($cmd,$udom,$uname,$namespace,$rid,$what)
1112: =split(/:/,$userinput);
1.8 www 1113: $namespace=~s/\//\_/g;
1.7 www 1114: $namespace=~s/\W//g;
1115: if ($namespace ne 'roles') {
1116: chomp($what);
1117: my $proname=propath($udom,$uname);
1118: my $now=time;
1.48 www 1119: unless ($namespace=~/^nohist\_/) {
1.7 www 1120: my $hfh;
1121: if (
1122: $hfh=IO::File->new(">>$proname/$namespace.hist")
1123: ) { print $hfh "P:$now:$rid:$what\n"; }
1124: }
1125: my @pairs=split(/\&/,$what);
1126:
1127: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {
1128: my @previouskeys=split(/&/,$hash{"keys:$rid"});
1129: my $key;
1130: $hash{"version:$rid"}++;
1131: my $version=$hash{"version:$rid"};
1132: my $allkeys='';
1133: foreach $pair (@pairs) {
1134: ($key,$value)=split(/=/,$pair);
1135: $allkeys.=$key.':';
1136: $hash{"$version:$rid:$key"}=$value;
1137: }
1.36 www 1138: $hash{"$version:$rid:timestamp"}=$now;
1139: $allkeys.='timestamp';
1.7 www 1140: $hash{"$version:keys:$rid"}=$allkeys;
1141: if (untie(%hash)) {
1142: print $client "ok\n";
1143: } else {
1144: print $client "error:$!\n";
1145: }
1146: } else {
1147: print $client "error:$!\n";
1148: }
1149: } else {
1150: print $client "refused\n";
1151: }
1152: # --------------------------------------------------------------------- restore
1153: } elsif ($userinput =~ /^restore/) {
1154: my ($cmd,$udom,$uname,$namespace,$rid)
1155: =split(/:/,$userinput);
1.8 www 1156: $namespace=~s/\//\_/g;
1.7 www 1157: $namespace=~s/\W//g;
1158: chomp($rid);
1159: my $proname=propath($udom,$uname);
1160: my $qresult='';
1.20 www 1161: if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
1.7 www 1162: my $version=$hash{"version:$rid"};
1163: $qresult.="version=$version&";
1164: my $scope;
1165: for ($scope=1;$scope<=$version;$scope++) {
1166: my $vkeys=$hash{"$scope:keys:$rid"};
1167: my @keys=split(/:/,$vkeys);
1168: my $key;
1169: $qresult.="$scope:keys=$vkeys&";
1170: foreach $key (@keys) {
1.21 www 1171: $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
1.7 www 1172: }
1.1 albertel 1173: }
1.4 www 1174: if (untie(%hash)) {
1.1 albertel 1175: $qresult=~s/\&$//;
1176: print $client "$qresult\n";
1177: } else {
1178: print $client "error:$!\n";
1179: }
1180: } else {
1181: print $client "error:$!\n";
1182: }
1.12 harris41 1183: # ------------------------------------------------------------------- querysend
1184: } elsif ($userinput =~ /^querysend/) {
1.44 harris41 1185: my ($cmd,$query,
1186: $custom,$customshow)=split(/:/,$userinput);
1.12 harris41 1187: $query=~s/\n*$//g;
1.45 harris41 1188: unless ($custom or $customshow) {
1.40 harris41 1189: print $client "".
1190: sqlreply("$hostid{$clientip}\&$query")."\n";
1191: }
1192: else {
1193: print $client "".
1194: sqlreply("$hostid{$clientip}\&$query".
1.44 harris41 1195: "\&$custom"."\&$customshow")."\n";
1.40 harris41 1196: }
1.12 harris41 1197: # ------------------------------------------------------------------ queryreply
1198: } elsif ($userinput =~ /^queryreply/) {
1199: my ($cmd,$id,$reply)=split(/:/,$userinput);
1200: my $store;
1.13 www 1201: my $execdir=$perlvar{'lonDaemons'};
1202: if ($store=IO::File->new(">$execdir/tmp/$id")) {
1.43 harris41 1203: $reply=~s/\&/\n/g;
1.12 harris41 1204: print $store $reply;
1205: close $store;
1.46 harris41 1206: my $store2=IO::File->new(">$execdir/tmp/$id.end");
1207: print $store2 "done\n";
1208: close $store2;
1.12 harris41 1209: print $client "ok\n";
1210: }
1211: else {
1212: print $client "error:$!\n";
1213: }
1.1 albertel 1214: # ----------------------------------------------------------------------- idput
1215: } elsif ($userinput =~ /^idput/) {
1216: my ($cmd,$udom,$what)=split(/:/,$userinput);
1217: chomp($what);
1218: $udom=~s/\W//g;
1219: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1220: my $now=time;
1221: {
1222: my $hfh;
1223: if (
1224: $hfh=IO::File->new(">>$proname.hist")
1225: ) { print $hfh "P:$now:$what\n"; }
1226: }
1227: my @pairs=split(/\&/,$what);
1.4 www 1228: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {
1.1 albertel 1229: foreach $pair (@pairs) {
1230: ($key,$value)=split(/=/,$pair);
1231: $hash{$key}=$value;
1232: }
1.4 www 1233: if (untie(%hash)) {
1.1 albertel 1234: print $client "ok\n";
1235: } else {
1236: print $client "error:$!\n";
1237: }
1238: } else {
1239: print $client "error:$!\n";
1240: }
1241: # ----------------------------------------------------------------------- idget
1242: } elsif ($userinput =~ /^idget/) {
1243: my ($cmd,$udom,$what)=split(/:/,$userinput);
1244: chomp($what);
1245: $udom=~s/\W//g;
1246: my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
1247: my @queries=split(/\&/,$what);
1248: my $qresult='';
1.20 www 1249: if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
1.1 albertel 1250: for ($i=0;$i<=$#queries;$i++) {
1251: $qresult.="$hash{$queries[$i]}&";
1252: }
1.4 www 1253: if (untie(%hash)) {
1.1 albertel 1254: $qresult=~s/\&$//;
1255: print $client "$qresult\n";
1256: } else {
1257: print $client "error:$!\n";
1258: }
1259: } else {
1260: print $client "error:$!\n";
1261: }
1.13 www 1262: # ---------------------------------------------------------------------- tmpput
1263: } elsif ($userinput =~ /^tmpput/) {
1264: my ($cmd,$what)=split(/:/,$userinput);
1265: my $store;
1266: $tmpsnum++;
1267: my $id=$$.'_'.$clientip.'_'.$tmpsnum;
1268: $id=~s/\W/\_/g;
1269: $what=~s/\n//g;
1270: my $execdir=$perlvar{'lonDaemons'};
1271: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
1272: print $store $what;
1273: close $store;
1274: print $client "$id\n";
1275: }
1276: else {
1277: print $client "error:$!\n";
1278: }
1279:
1280: # ---------------------------------------------------------------------- tmpget
1281: } elsif ($userinput =~ /^tmpget/) {
1282: my ($cmd,$id)=split(/:/,$userinput);
1283: chomp($id);
1284: $id=~s/\W/\_/g;
1285: my $store;
1286: my $execdir=$perlvar{'lonDaemons'};
1287: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
1288: my $reply=<$store>;
1289: print $client "$reply\n";
1290: close $store;
1291: }
1292: else {
1293: print $client "error:$!\n";
1294: }
1295:
1.5 www 1296: # -------------------------------------------------------------------------- ls
1297: } elsif ($userinput =~ /^ls/) {
1298: my ($cmd,$ulsdir)=split(/:/,$userinput);
1299: my $ulsout='';
1300: my $ulsfn;
1301: if (-e $ulsdir) {
1.41 www 1302: if (opendir(LSDIR,$ulsdir)) {
1303: while ($ulsfn=readdir(LSDIR)) {
1.47 www 1304: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1.5 www 1305: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1306: }
1.41 www 1307: closedir(LSDIR);
1308: }
1.5 www 1309: } else {
1310: $ulsout='no_such_dir';
1311: }
1.17 www 1312: if ($ulsout eq '') { $ulsout='empty'; }
1.5 www 1313: print $client "$ulsout\n";
1.51 www 1314: # ------------------------------------------------------------------ Hanging up
1315: } elsif (($userinput =~ /^exit/) ||
1316: ($userinput =~ /^init/)) {
1317: &logthis(
1318: "Client $clientip ($hostid{$clientip}) hanging up: $userinput");
1319: print $client "bye\n";
1.59 www 1320: $client->close();
1.51 www 1321: last;
1.1 albertel 1322: # ------------------------------------------------------------- unknown command
1323: } else {
1324: # unknown command
1325: print $client "unknown_cmd\n";
1326: }
1.58 www 1327: # -------------------------------------------------------------------- complete
1328: &status('Listening to '.$hostid{$clientip});
1329: }
1.59 www 1330: # --------------------------------------------- client unknown or fishy, refuse
1.1 albertel 1331: } else {
1332: print $client "refused\n";
1.59 www 1333: $client->close();
1.9 www 1334: &logthis("<font color=blue>WARNING: "
1335: ."Rejected client $clientip, closing connection</font>");
1.1 albertel 1336: }
1.9 www 1337: &logthis("<font color=red>CRITICAL: "
1.10 www 1338: ."Disconnect from $clientip ($hostid{$clientip})</font>");
1.1 albertel 1339: # =============================================================================
1340: }
1341:
1342: # tidy up gracefully and finish
1343:
1.59 www 1344: $client->close();
1345: $server->close();
1346:
1.1 albertel 1347: # this exit is VERY important, otherwise the child will become
1348: # a producer of more and more children, forking yourself into
1349: # process death.
1350: exit;
1351: }
1352: }
1353:
1354:
1355:
1356:
1357:
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