Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Roles have starting and end time
Bug fixes after replication shift
New login screen
Authenticator routes to roles screen
Form variables are transfered to environment (not tested)

    1: # The LearningOnline Network
    2: # TCP networking package
    3: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
    4: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
    5: # 11/8,11/16,11/18,11/22,11/23,12/22,
    6: # 01/06,01/13 Gerd Kortemeyer
    7: 
    8: package Apache::lonnet;
    9: 
   10: use strict;
   11: use Apache::File;
   12: use LWP::UserAgent();
   13: use vars qw(%perlvar %hostname %homecache %spareid %hostdom %libserv $readit);
   14: use IO::Socket;
   15: use Apache::Constants qw(:common :http);
   16: 
   17: # --------------------------------------------------------------------- Logging
   18: 
   19: sub logthis {
   20:     my $message=shift;
   21:     my $execdir=$perlvar{'lonDaemons'};
   22:     my $now=time;
   23:     my $local=localtime($now);
   24:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
   25:     print $fh "$local ($$): $message\n";
   26:     return 1;
   27: }
   28: 
   29: sub logperm {
   30:     my $message=shift;
   31:     my $execdir=$perlvar{'lonDaemons'};
   32:     my $now=time;
   33:     my $local=localtime($now);
   34:     my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
   35:     print $fh "$now:$message:$local\n";
   36:     return 1;
   37: }
   38: 
   39: # -------------------------------------------------- Non-critical communication
   40: sub subreply {
   41:     my ($cmd,$server)=@_;
   42:     my $peerfile="$perlvar{'lonSockDir'}/$server";
   43:     my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
   44:                                      Type    => SOCK_STREAM,
   45:                                      Timeout => 10)
   46:        or return "con_lost";
   47:     print $client "$cmd\n";
   48:     my $answer=<$client>;
   49:     if (!$answer) { $answer="con_lost"; }
   50:     chomp($answer);
   51:     return $answer;
   52: }
   53: 
   54: sub reply {
   55:     my ($cmd,$server)=@_;
   56:     my $answer=subreply($cmd,$server);
   57:     if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
   58:     return $answer;
   59: }
   60: 
   61: # ----------------------------------------------------------- Send USR1 to lonc
   62: 
   63: sub reconlonc {
   64:     my $peerfile=shift;
   65:     &logthis("Trying to reconnect for $peerfile");
   66:     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
   67:     if (my $fh=Apache::File->new("$loncfile")) {
   68: 	my $loncpid=<$fh>;
   69:         chomp($loncpid);
   70:         if (kill 0 => $loncpid) {
   71: 	    &logthis("lonc at pid $loncpid responding, sending USR1");
   72:             kill USR1 => $loncpid;
   73:             sleep 1;
   74:             if (-e "$peerfile") { return; }
   75:             &logthis("$peerfile still not there, give it another try");
   76:             sleep 5;
   77:             if (-e "$peerfile") { return; }
   78:             &logthis("$peerfile still not there, giving up");
   79:         } else {
   80: 	    &logthis("lonc at pid $loncpid not responding, giving up");
   81:         }
   82:     } else {
   83:         &logthis('lonc not running, giving up');
   84:     }
   85: }
   86: 
   87: # ------------------------------------------------------ Critical communication
   88: sub critical {
   89:     my ($cmd,$server)=@_;
   90:     my $answer=reply($cmd,$server);
   91:     if ($answer eq 'con_lost') {
   92:         my $pingreply=reply('ping',$server);
   93: 	&reconlonc("$perlvar{'lonSockDir'}/$server");
   94:         my $pongreply=reply('pong',$server);
   95:         &logthis("Ping/Pong for $server: $pingreply/$pongreply");
   96:         $answer=reply($cmd,$server);
   97:         if ($answer eq 'con_lost') {
   98:             my $now=time;
   99:             my $middlename=$cmd;
  100:             $middlename=substr($middlename,0,16);
  101:             $middlename=~s/\W//g;
  102:             my $dfilename=
  103:              "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
  104:             {
  105:              my $dfh;
  106:              if ($dfh=Apache::File->new(">$dfilename")) {
  107:                 print $dfh "$cmd\n";
  108: 	     }
  109:             }
  110:             sleep 2;
  111:             my $wcmd='';
  112:             {
  113: 	     my $dfh;
  114:              if ($dfh=Apache::File->new("$dfilename")) {
  115:                 $wcmd=<$dfh>;
  116: 	     }
  117:             }
  118:             chomp($wcmd);
  119:             if ($wcmd eq $cmd) {
  120: 		&logthis("Connection buffer $dfilename: $cmd");
  121:                 &logperm("D:$server:$cmd");
  122: 	        return 'con_delayed';
  123:             } else {
  124:                 &logthis("CRITICAL CONNECTION FAILED: $server $cmd");
  125:                 &logperm("F:$server:$cmd");
  126:                 return 'con_failed';
  127:             }
  128:         }
  129:     }
  130:     return $answer;
  131: }
  132: 
  133: # ---------------------------------------------------------- Append Environment
  134: 
  135: sub appenv {
  136:     my %newenv=@_;
  137:     my @oldenv;
  138:     {
  139:      my $fh;
  140:      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
  141: 	return 'error';
  142:      }
  143:      @oldenv=<$fh>;
  144:     }
  145:     for (my $i=0; $i<=$#oldenv; $i++) {
  146:         chomp($oldenv[$i]);
  147:         if ($oldenv[$i] ne '') {
  148:            my ($name,$value)=split(/=/,$oldenv[$i]);
  149: 	   $newenv{$name}=$value;
  150:         }
  151:     }
  152:     {
  153:      my $fh;
  154:      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
  155: 	return 'error';
  156:      }
  157:      my $newname;
  158:      foreach $newname (keys %newenv) {
  159: 	 print $fh "$newname=$newenv{$newname}\n";
  160:      }
  161:     }
  162:     return 'ok';
  163: }
  164: 
  165: # ------------------------------ Find server with least workload from spare.tab
  166: sub spareserver {
  167:     my $tryserver;
  168:     my $spareserver='';
  169:     my $lowestserver=100;
  170:     foreach $tryserver (keys %spareid) {
  171:        my $answer=reply('load',$tryserver);
  172:        if (($answer =~ /\d/) && ($answer<$lowestserver)) {
  173: 	   $spareserver="http://$hostname{$tryserver}";
  174:            $lowestserver=$answer;
  175:        }
  176:     }    
  177:     return $spareserver;
  178: }
  179: 
  180: # --------- Try to authenticate user from domain's lib servers (first this one)
  181: sub authenticate {
  182:     my ($uname,$upass,$udom)=@_;
  183: 
  184:     if (($perlvar{'lonRole'} eq 'library') && 
  185:         ($udom eq $perlvar{'lonDefDomain'})) {
  186:     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
  187:         if ($answer =~ /authorized/) {
  188:               if ($answer eq 'authorized') {
  189:                  &logthis("User $uname at $udom authorized by local server"); 
  190:                  return $perlvar{'lonHostID'}; 
  191:               }
  192:               if ($answer eq 'non_authorized') {
  193:                  &logthis("User $uname at $udom rejected by local server"); 
  194:                  return 'no_host'; 
  195:               }
  196: 	}
  197:     }
  198: 
  199:     my $tryserver;
  200:     foreach $tryserver (keys %libserv) {
  201: 	if ($hostdom{$tryserver} eq $udom) {
  202:            my $answer=reply("enc:auth:$udom:$uname:$upass",$tryserver);
  203:            if ($answer =~ /authorized/) {
  204:               if ($answer eq 'authorized') {
  205:                  &logthis("User $uname at $udom authorized by $tryserver"); 
  206:                  return $tryserver; 
  207:               }
  208:               if ($answer eq 'non_authorized') {
  209:                  &logthis("User $uname at $udom rejected by $tryserver");
  210:                  return 'no_host';
  211:               } 
  212: 	   }
  213:        }
  214:     }
  215:     &logthis("User $uname at $udom could not be authenticated");    
  216:     return 'no_host';
  217: }
  218: 
  219: # ---------------------- Find the homebase for a user from domain's lib servers
  220: sub homeserver {
  221:     my ($uname,$udom)=@_;
  222: 
  223:     my $index="$uname:$udom";
  224:     if ($homecache{$index}) { return "$homecache{$index}"; }
  225: 
  226:     my $tryserver;
  227:     foreach $tryserver (keys %libserv) {
  228: 	if ($hostdom{$tryserver} eq $udom) {
  229:            my $answer=reply("home:$udom:$uname",$tryserver);
  230:            if ($answer eq 'found') { 
  231: 	      $homecache{$index}=$tryserver;
  232:               return $tryserver; 
  233: 	   }
  234:        }
  235:     }    
  236:     return 'no_host';
  237: }
  238: 
  239: # ----------------------------- Subscribe to a resource, return URL if possible
  240: sub subscribe {
  241:     my $fname=shift;
  242:     my $author=$fname;
  243:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
  244:     my ($udom,$uname)=split(/\//,$author);
  245:     my $home=homeserver($uname,$udom);
  246:     if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { 
  247:         return 'not_found'; 
  248:     }
  249:     my $answer=reply("sub:$fname",$home);
  250:     return $answer;
  251: }
  252:     
  253: # -------------------------------------------------------------- Replicate file
  254: 
  255: sub repcopy {
  256:     my $filename=shift;
  257:     my $transname="$filename.in.transfer";
  258:     my $remoteurl=subscribe($filename);
  259:     if ($remoteurl eq 'con_lost') {
  260: 	   &logthis("Subscribe returned con_lost: $filename");
  261:            return HTTP_SERVICE_UNAVAILABLE;
  262:     } elsif ($remoteurl eq 'not_found') {
  263: 	   &logthis("Subscribe returned not_found: $filename");
  264: 	   return HTTP_NOT_FOUND;
  265:     } elsif ($remoteurl eq 'forbidden') {
  266: 	   &logthis("Subscribe returned forbidden: $filename");
  267:            return FORBIDDEN;
  268:     } else {
  269:            my @parts=split(/\//,$filename);
  270:            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
  271:            if ($path ne "$perlvar{'lonDocRoot'}/res") {
  272:                &logthis("Malconfiguration for replication: $filename");
  273: 	       return HTTP_BAD_REQUEST;
  274:            }
  275:            my $count;
  276:            for ($count=5;$count<$#parts;$count++) {
  277:                $path.="/$parts[$count]";
  278:                if ((-e $path)!=1) {
  279: 		   mkdir($path,0777);
  280:                }
  281:            }
  282:            my $ua=new LWP::UserAgent;
  283:            my $request=new HTTP::Request('GET',"$remoteurl");
  284:            my $response=$ua->request($request,$transname);
  285:            if ($response->is_error()) {
  286: 	       unlink($transname);
  287:                my $message=$response->status_line;
  288:                &logthis("LWP GET: $message: $filename");
  289:                return HTTP_SERVICE_UNAVAILABLE;
  290:            } else {
  291:                rename($transname,$filename);
  292:                return OK;
  293:            }
  294:     }
  295: }
  296: 
  297: # ----------------------------------------------------------------------- Store
  298: 
  299: sub store {
  300:     my %storehash=shift;
  301:     my $command="store:$ENV{'user.domain'}:$ENV{'user.name'}:"
  302:                ."$ENV{'user.class'}:$ENV{'request.filename'}:";
  303: }
  304: 
  305: # --------------------------------------------------------------------- Restore
  306: 
  307: sub restore {
  308:     my $command="restore:$ENV{'user.domain'}:$ENV{'user.name'}:"
  309:                ."$ENV{'user.class'}:$ENV{'request.filename'}:";
  310: }
  311: 
  312: # ================================================================ Main Program
  313: 
  314: sub BEGIN {
  315: if ($readit ne 'done') {
  316: # ------------------------------------------------------------ Read access.conf
  317: {
  318:     my $config=Apache::File->new("/etc/httpd/conf/access.conf");
  319: 
  320:     while (my $configline=<$config>) {
  321:         if ($configline =~ /PerlSetVar/) {
  322: 	   my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
  323:            chomp($varvalue);
  324:            $perlvar{$varname}=$varvalue;
  325:         }
  326:     }
  327: }
  328: 
  329: # ------------------------------------------------------------- Read hosts file
  330: {
  331:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
  332: 
  333:     while (my $configline=<$config>) {
  334:        my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
  335:        $hostname{$id}=$name;
  336:        $hostdom{$id}=$domain;
  337:        if ($role eq 'library') { $libserv{$id}=$name; }
  338:     }
  339: }
  340: 
  341: # ------------------------------------------------------ Read spare server file
  342: {
  343:     my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
  344: 
  345:     while (my $configline=<$config>) {
  346:        chomp($configline);
  347:        if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
  348:           $spareid{$configline}=1;
  349:        }
  350:     }
  351: }
  352: $readit='done';
  353: &logthis('Read configuration');
  354: }
  355: }
  356: 1;
  357: 
  358: 
  359: