Annotation of loncom/lond, revision 1.1

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>