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