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