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