File:  [LON-CAPA] / loncom / lond
Revision 1.4: download - view: text, annotated - select for diffs
Thu Nov 4 20:53:04 1999 UTC (25 years ago) by www
Branches: MAIN
CVS tags: HEAD
Changed database open and close to tie and untie
Retested - seems like GDBM incompatible with old datafiles, but so what?
Tested Kerberos - seems to work

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

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