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