[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.832 and 1.839

version 1.832, 2007/02/16 01:04:19 version 1.839, 2007/03/02 23:43:24
Line 35  use HTTP::Headers; Line 35  use HTTP::Headers;
 use HTTP::Date;  use HTTP::Date;
 # use Date::Parse;  # use Date::Parse;
 use vars   use vars 
 qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom   qw(%perlvar %badServerCache %iphost %spareid %hostdom 
    %libserv %pr %prp $memcache %packagetab      %libserv %pr %prp $memcache %packagetab 
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf     %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
Line 149  sub logperm { Line 149  sub logperm {
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};      my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
     #      #
     #  With loncnew process trimming, there's a timing hole between lonc server      #  With loncnew process trimming, there's a timing hole between lonc server
     #  process exit and the master server picking up the listen on the AF_UNIX      #  process exit and the master server picking up the listen on the AF_UNIX
Line 189  sub subreply { Line 189  sub subreply {
   
 sub reply {  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined(&hostname($server))) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=\"blue\">WARNING:".         &logthis("<font color=\"blue\">WARNING:".
Line 201  sub reply { Line 201  sub reply {
 # ----------------------------------------------------------- Send USR1 to lonc  # ----------------------------------------------------------- Send USR1 to lonc
   
 sub reconlonc {  sub reconlonc {
     my $peerfile=shift;      &logthis("Trying to reconnect lonc");
     &logthis("Trying to reconnect for $peerfile");  
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";      my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
     if (open(my $fh,"<$loncfile")) {      if (open(my $fh,"<$loncfile")) {
  my $loncpid=<$fh>;   my $loncpid=<$fh>;
Line 211  sub reconlonc { Line 210  sub reconlonc {
     &logthis("lonc at pid $loncpid responding, sending USR1");      &logthis("lonc at pid $loncpid responding, sending USR1");
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
             sleep 1;              sleep 1;
             if (-e "$peerfile") { return; }           } else {
             &logthis("$peerfile still not there, give it another try");  
             sleep 5;  
             if (-e "$peerfile") { return; }  
             &logthis(  
   "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");  
         } else {  
     &logthis(      &logthis(
                "<font color=\"blue\">WARNING:".                 "<font color=\"blue\">WARNING:".
                " lonc at pid $loncpid not responding, giving up</font>");                 " lonc at pid $loncpid not responding, giving up</font>");
         }          }
     } else {      } else {
      &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');   &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
     }      }
 }  }
   
Line 231  sub reconlonc { Line 224  sub reconlonc {
   
 sub critical {  sub critical {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless ($hostname{$server}) {      unless (&hostname($server)) {
         &logthis("<font color=\"blue\">WARNING:".          &logthis("<font color=\"blue\">WARNING:".
                " Critical message to unknown server ($server)</font>");                 " Critical message to unknown server ($server)</font>");
         return 'no_such_host';          return 'no_such_host';
Line 524  sub spareserver { Line 517  sub spareserver {
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
  $spare_server="http://$hostname{$spare_server}";   $spare_server="http://".&hostname($spare_server);
     }      }
     return $spare_server;      return $spare_server;
 }  }
Line 615  sub authenticate { Line 608  sub authenticate {
     my ($uname,$upass,$udom)=@_;      my ($uname,$upass,$udom)=@_;
     $upass=&escape($upass);      $upass=&escape($upass);
     $uname= &LONCAPA::clean_username($uname);      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom,1);
     if (!$uhome) {      if ((!$uhome) || ($uhome eq 'no_host')) {
  &logthis("User $uname at $udom is unknown in authenticate");  # Maybe the machine was offline and only re-appeared again recently?
           &reconlonc();
   # One more
    my $uhome=&homeserver($uname,$udom,1);
    if ((!$uhome) || ($uhome eq 'no_host')) {
       &logthis("User $uname at $udom is unknown in authenticate");
    }
  return 'no_host';   return 'no_host';
     }      }
     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);      my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
Line 647  sub homeserver { Line 646  sub homeserver {
  exists($badServerCache{$tryserver}));   exists($badServerCache{$tryserver}));
  if ($hostdom{$tryserver} eq $udom) {   if ($hostdom{$tryserver} eq $udom) {
            my $answer=reply("home:$udom:$uname",$tryserver);             my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') {              if ($answer eq 'found') {
                  delete($badServerCache{$tryserver}); 
        return $homecache{$index}=$tryserver;         return $homecache{$index}=$tryserver;
            } elsif ($answer eq 'no_host') {             } elsif ($answer eq 'no_host') {
        $badServerCache{$tryserver}=1;         $badServerCache{$tryserver}=1;
Line 766  sub put_dom { Line 766  sub put_dom {
     }      }
 }  }
   
   sub retrieve_inst_usertypes {
       my ($udom) = @_;
       my (%returnhash,@order);
       if (exists($domain_primary{$udom})) {
           my $uhome=$domain_primary{$udom};
           my $rep=&reply("inst_usertypes:$udom",$uhome);
           my ($hashitems,$orderitems) = split(/:/,$rep); 
           my @pairs=split(/\&/,$hashitems);
           foreach my $item (@pairs) {
               my ($key,$value)=split(/=/,$item,2);
               $key = &unescape($key);
               next if ($key =~ /^error: 2 /);
               $returnhash{$key}=&thaw_unescape($value);
           }
           my @esc_order = split(/\&/,$orderitems);
           foreach my $item (@esc_order) {
               push(@order,&unescape($item));
           }
       } else {
           &logthis("get_dom failed - no primary domain server for $udom");
       }
       return (\%returnhash,\@order);
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 2271  sub checkin { Line 2295  sub checkin {
     my $now=time;      my $now=time;
     my ($ta,$tb,$lonhost)=split(/\*/,$token);      my ($ta,$tb,$lonhost)=split(/\*/,$token);
     $lonhost=~tr/A-Z/a-z/;      $lonhost=~tr/A-Z/a-z/;
     my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;      my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
     $dtoken=~s/\W/\_/g;      $dtoken=~s/\W/\_/g;
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=      my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));                   split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
Line 2940  sub custom_roleprivs { Line 2964  sub custom_roleprivs {
     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;      my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
     my $homsvr=homeserver($rauthor,$rdomain);      my $homsvr=homeserver($rauthor,$rdomain);
     if ($hostname{$homsvr} ne '') {      if (&hostname($homsvr) ne '') {
         my ($rdummy,$roledef)=          my ($rdummy,$roledef)=
             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);              &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
         if (($rdummy ne 'con_lost') && ($roledef ne '')) {          if (($rdummy ne 'con_lost') && ($roledef ne '')) {
Line 4171  sub log_query { Line 4195  sub log_query {
     my ($uname,$udom,$query,%filters)=@_;      my ($uname,$udom,$query,%filters)=@_;
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if ($uhome eq 'no_host') { return 'error: no_host'; }      if ($uhome eq 'no_host') { return 'error: no_host'; }
     my $uhost=$hostname{$uhome};      my $uhost=&hostname($uhome);
     my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));      my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
     my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,      my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
                        $uhome);                         $uhome);
Line 4203  sub fetch_enrollment_query { Line 4227  sub fetch_enrollment_query {
     } else {      } else {
         $homeserver = &homeserver($cnum,$dom);          $homeserver = &homeserver($cnum,$dom);
     }      }
     my $host=$hostname{$homeserver};      my $host=&hostname($homeserver);
     my $cmd = '';      my $cmd = '';
     foreach my $affiliate (keys %{$affiliatesref}) {      foreach my $affiliate (keys %{$affiliatesref}) {
         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';          $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
Line 4394  sub auto_photochoice { Line 4418  sub auto_photochoice {
 sub auto_photoupdate {  sub auto_photoupdate {
     my ($affiliatesref,$dom,$cnum,$photo) = @_;      my ($affiliatesref,$dom,$cnum,$photo) = @_;
     my $homeserver = &homeserver($cnum,$dom);      my $homeserver = &homeserver($cnum,$dom);
     my $host=$hostname{$homeserver};      my $host=&hostname($homeserver);
     my $cmd = '';      my $cmd = '';
     my $maxtries = 1;      my $maxtries = 1;
     foreach my $affiliate (keys(%{$affiliatesref})) {      foreach my $affiliate (keys(%{$affiliatesref})) {
Line 5134  sub is_locked { Line 5158  sub is_locked {
   
 sub declutter_portfile {  sub declutter_portfile {
     my ($file) = @_;      my ($file) = @_;
     &logthis("got $file");      $file =~ s{^(/portfolio/|portfolio/)}{/};
     $file =~ s-^(/portfolio/|portfolio/)-/-;  
     &logthis("ret $file");  
     return $file;      return $file;
 }  }
   
Line 7087  sub setup_random_from_rndseed { Line 7109  sub setup_random_from_rndseed {
 }  }
   
 sub latest_receipt_algorithm_id {  sub latest_receipt_algorithm_id {
     return 'receipt2';      return 'receipt3';
 }  }
   
 sub recunique {  sub recunique {
     my $fucourseid=shift;      my $fucourseid=shift;
     my $unique;      my $unique;
     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {      if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
    $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
  $unique=$env{"course.$fucourseid.internal.encseed"};   $unique=$env{"course.$fucourseid.internal.encseed"};
     } else {      } else {
  $unique=$perlvar{'lonReceipt'};   $unique=$perlvar{'lonReceipt'};
Line 7104  sub recunique { Line 7127  sub recunique {
 sub recprefix {  sub recprefix {
     my $fucourseid=shift;      my $fucourseid=shift;
     my $prefix;      my $prefix;
     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {      if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'||
    $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
  $prefix=$env{"course.$fucourseid.internal.encpref"};   $prefix=$env{"course.$fucourseid.internal.encpref"};
     } else {      } else {
  $prefix=$perlvar{'lonHostID'};   $prefix=$perlvar{'lonHostID'};
Line 7114  sub recprefix { Line 7138  sub recprefix {
   
 sub ireceipt {  sub ireceipt {
     my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;      my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
   
       my $return =&recprefix($fucourseid).'-';
   
       if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' ||
    $env{'request.state'} eq 'construct') {
    $return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
    return $return;
       }
   
     my $cuname=unpack("%32C*",$funame);      my $cuname=unpack("%32C*",$funame);
     my $cudom=unpack("%32C*",$fudom);      my $cudom=unpack("%32C*",$fudom);
     my $cucourseid=unpack("%32C*",$fucourseid);      my $cucourseid=unpack("%32C*",$fucourseid);
     my $cusymb=unpack("%32C*",$fusymb);      my $cusymb=unpack("%32C*",$fusymb);
     my $cunique=&recunique($fucourseid);      my $cunique=&recunique($fucourseid);
     my $cpart=unpack("%32S*",$part);      my $cpart=unpack("%32S*",$part);
     my $return =&recprefix($fucourseid).'-';      if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||  
  $env{'request.state'} eq 'construct') {  
  #&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));   #&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
                 
  $return.= ($cunique%$cuname+   $return.= ($cunique%$cuname+
Line 7254  sub repcopy_userfile { Line 7286  sub repcopy_userfile {
     if (-e $transferfile) { return 'ok'; }      if (-e $transferfile) { return 'ok'; }
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);      $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
     my $response=$ua->request($request,$transferfile);      my $response=$ua->request($request,$transferfile);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
Line 7277  sub tokenwrapper { Line 7309  sub tokenwrapper {
     if ($udom && $uname && $file) {      if ($udom && $uname && $file) {
  $file=~s|(\?\.*)*$||;   $file=~s|(\?\.*)*$||;
         &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});          &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
         return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.          return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 7292  sub tokenwrapper { Line 7324  sub tokenwrapper {
 sub getuploaded {  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
     $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;      $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=$ua->request($request);
Line 7382  sub hreflocation { Line 7414  sub hreflocation {
 }  }
   
 sub current_machine_domains {  sub current_machine_domains {
     my $hostname=$hostname{$perlvar{'lonHostID'}};      my $hostname=&hostname($perlvar{'lonHostID'});
     my @domains;      my @domains;
       my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {      while( my($id, $name) = each(%hostname)) {
 # &logthis("-$id-$name-$hostname-");  # &logthis("-$id-$name-$hostname-");
  if ($hostname eq $name) {   if ($hostname eq $name) {
Line 7394  sub current_machine_domains { Line 7427  sub current_machine_domains {
 }  }
   
 sub current_machine_ids {  sub current_machine_ids {
     my $hostname=$hostname{$perlvar{'lonHostID'}};      my $hostname=&hostname($perlvar{'lonHostID'});
     my @ids;      my @ids;
       my %hostname = &all_hostnames();
     while( my($id, $name) = each(%hostname)) {      while( my($id, $name) = each(%hostname)) {
 # &logthis("-$id-$name-$hostname-");  # &logthis("-$id-$name-$hostname-");
  if ($hostname eq $name) {   if ($hostname eq $name) {
Line 7573  BEGIN { Line 7607  BEGIN {
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
 {  {
       my %hostname;
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
Line 7589  BEGIN { Line 7624  BEGIN {
     close($config);      close($config);
     # FIXME: dev server don't want this, production servers _do_ want this      # FIXME: dev server don't want this, production servers _do_ want this
     #&get_iphost();      #&get_iphost();
   
       sub hostname {
    my ($lonid) = @_;
    return $hostname{$lonid};
       }
       sub all_hostnames {
    return %hostname;
       }
   }
   
   sub get_hosts_from_ip {
       my ($ip) = @_;
       my %iphosts = &get_iphost();
       if (ref($iphosts{$ip})) {
    return @{$iphosts{$ip}};
       }
       return;
 }  }
   
 sub get_iphost {  sub get_iphost {
     if (%iphost) { return %iphost; }      if (%iphost) { return %iphost; }
     my %name_to_ip;      my %name_to_ip;
       my %hostname = &all_hostnames();
     foreach my $id (keys(%hostname)) {      foreach my $id (keys(%hostname)) {
  my $name=$hostname{$id};   my $name=$hostname{$id};
  my $ip;   my $ip;
Line 7973  explanation of a user role term Line 8026  explanation of a user role term
   
 =item *  =item *
   
 get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are optional.  Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for the role. If no username and domain are specified, will default to current user/domain. Types, roles, and roledoms are references to arrays, of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list if roles reported. If no array ref is provided for types, will default to return only active roles.    get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are
   optional.  Returns a hash of a user's roles, with keys set to
   colon-sparated $uname,$udom,and $role, and value set to
   colon-separated start and end times for the role. If no username and
   domain are specified, will default to current user/domain. Types,
   roles, and roledoms are references to arrays, of role statuses
   (active, future or previous), roles (e.g., cc,in, st etc.) and domains
   of the roles which can be used to restrict the list if roles
   reported. If no array ref is provided for types, will default to
   return only active roles.
   
 =back  =back
   
 =head2 User Modification  =head2 User Modification
Removed from v.1.832  
changed lines
  Added in v.1.839

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