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