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