[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.536 and 1.570

version 1.536, 2017/05/09 03:04:21 version 1.570, 2021/12/20 03:13:29
Line 80  my $clientsamedom;              # LonCAP Line 80  my $clientsamedom;              # LonCAP
                                 # and client.                                  # and client.
 my $clientsameinst;             # LonCAPA "internet domain" same for   my $clientsameinst;             # LonCAPA "internet domain" same for 
                                 # this host and client.                                  # this host and client.
 my $clientremoteok;             # Client allowed to host domain's users.  my $clientremoteok;             # Current domain permits hosting on client
                                 # (version constraints ignored), not set                                  # (not set if host and client share "internet domain").
                                 # if this host and client share "internet domain".                                   # Values are 0 or 1; 1 if allowed.
 my %clientprohibited;           # Actions prohibited on client;  my %clientprohibited;           # Commands from client prohibited for domain's
                                    # users.
   
 my $server;  my $server;
   
 my $keymode;  my $keymode;
Line 108  my %perlvar;   # Will have the apache co Line 109  my %perlvar;   # Will have the apache co
 my %secureconf;                 # Will have requirements for security   my %secureconf;                 # Will have requirements for security 
                                 # of lond connections                                  # of lond connections
   
   my %crlchecked;                 # Will contain clients for which the client's SSL
                                   # has been checked against the cluster's Certificate
                                   # Revocation List.
   
 my $dist;  my $dist;
   
 #  #
Line 172  my @installerrors = ("ok", Line 177  my @installerrors = ("ok",
 # shared    ("Access to other domain's content by this domain")  # shared    ("Access to other domain's content by this domain")
 # enroll    ("Enrollment in this domain's courses by others")  # enroll    ("Enrollment in this domain's courses by others")
 # coaurem   ("Co-author roles for this domain's users elsewhere")  # coaurem   ("Co-author roles for this domain's users elsewhere")
   # othcoau   ("Co-author roles in this domain for others")
 # domroles  ("Domain roles in this domain assignable to others")  # domroles  ("Domain roles in this domain assignable to others")
 # catalog   ("Course Catalog for this domain displayed elsewhere")  # catalog   ("Course Catalog for this domain displayed elsewhere")
 # reqcrs    ("Requests for creation of courses in this domain by others")  # reqcrs    ("Requests for creation of courses in this domain by others")
Line 207  my %trust = ( Line 213  my %trust = (
                autovalidateclass_sec => {catalog => 1},                 autovalidateclass_sec => {catalog => 1},
                autovalidatecourse => {remote => 1, enroll => 1},                 autovalidatecourse => {remote => 1, enroll => 1},
                autovalidateinstcode => {domroles => 1, remote => 1, enroll => 1},                 autovalidateinstcode => {domroles => 1, remote => 1, enroll => 1},
                  autovalidateinstcrosslist => {remote => 1, enroll => 1},
                  autoinstsecreformat => {remote => 1, enroll => 1},
                changeuserauth => {remote => 1, domroles => 1},                 changeuserauth => {remote => 1, domroles => 1},
                chatretr => {remote => 1, enroll => 1},                 chatretr => {remote => 1, enroll => 1},
                chatsend => {remote => 1, enroll => 1},                 chatsend => {remote => 1, enroll => 1},
Line 214  my %trust = ( Line 222  my %trust = (
                courseidput => {remote => 1, domroles => 1, enroll => 1},                 courseidput => {remote => 1, domroles => 1, enroll => 1},
                courseidputhash => {remote => 1, domroles => 1, enroll => 1},                 courseidputhash => {remote => 1, domroles => 1, enroll => 1},
                courselastaccess => {remote => 1, domroles => 1, enroll => 1},                 courselastaccess => {remote => 1, domroles => 1, enroll => 1},
                  coursesessions => {institutiononly => 1},
                currentauth => {remote => 1, domroles => 1, enroll => 1},                 currentauth => {remote => 1, domroles => 1, enroll => 1},
                currentdump => {remote => 1, enroll => 1},                 currentdump => {remote => 1, enroll => 1},
                currentversion => {remote=> 1, content => 1},                 currentversion => {remote=> 1, content => 1},
                dcmaildump => {remote => 1, domroles => 1},                 dcmaildump => {remote => 1, domroles => 1},
                dcmailput => {remote => 1, domroles => 1},                 dcmailput => {remote => 1, domroles => 1},
                del => {remote => 1, domroles => 1, enroll => 1, content => 1},                 del => {remote => 1, domroles => 1, enroll => 1, content => 1},
                  delbalcookie => {institutiononly => 1},
                  delusersession => {institutiononly => 1},
                deldom => {remote => 1, domroles => 1}, # not currently used                 deldom => {remote => 1, domroles => 1}, # not currently used
                devalidatecache => {institutiononly => 1},                 devalidatecache => {institutiononly => 1},
                domroleput => {remote => 1, enroll => 1},                 domroleput => {remote => 1, enroll => 1},
Line 228  my %trust = ( Line 239  my %trust = (
                du2 => {remote => 1, enroll => 1},                 du2 => {remote => 1, enroll => 1},
                dump => {remote => 1, enroll => 1, domroles => 1},                 dump => {remote => 1, enroll => 1, domroles => 1},
                edit => {institutiononly => 1},  #not used currently                 edit => {institutiononly => 1},  #not used currently
                  edump => {remote => 1, enroll => 1, domroles => 1},
                eget => {remote => 1, domroles => 1, enroll => 1}, #not used currently                 eget => {remote => 1, domroles => 1, enroll => 1}, #not used currently
                egetdom => {remote => 1, domroles => 1, enroll => 1, },                 egetdom => {remote => 1, domroles => 1, enroll => 1, },
                ekey => {}, #not used currently                 ekey => {anywhere => 1},
                exit => {anywhere => 1},                 exit => {anywhere => 1},
                fetchuserfile => {remote => 1, enroll => 1},                 fetchuserfile => {remote => 1, enroll => 1},
                get => {remote => 1, domroles => 1, enroll => 1},                 get => {remote => 1, domroles => 1, enroll => 1},
Line 295  my %trust = ( Line 307  my %trust = (
                store => {remote => 1, enroll => 1, reqcrs => 1,},                 store => {remote => 1, enroll => 1, reqcrs => 1,},
                studentphoto => {remote => 1, enroll => 1},                 studentphoto => {remote => 1, enroll => 1},
                sub => {content => 1,},                 sub => {content => 1,},
                tmpdel => {anywhere => 1},                 tmpdel => {institutiononly => 1},
                tmpget => {anywhere => 1},                 tmpget => {institutiononly => 1},
                tmpput => {anywhere => 1},                 tmpput => {remote => 1, othcoau => 1},
                tokenauthuserfile => {anywhere => 1},                 tokenauthuserfile => {anywhere => 1},
                unsub => {content => 1,},                 unsub => {content => 1,},
                update => {shared => 1},                 update => {shared => 1},
                  updatebalcookie => {institutiononly => 1},
                updateclickers => {remote => 1},                 updateclickers => {remote => 1},
                userhassession => {anywhere => 1},                 userhassession => {anywhere => 1},
                userload => {anywhere => 1},                 userload => {anywhere => 1},
Line 420  sub SSLConnection { Line 433  sub SSLConnection {
     Debug("Approving promotion -> ssl");      Debug("Approving promotion -> ssl");
     #  And do so:      #  And do so:
   
       my $CRLFile;
       unless ($crlchecked{$clientname}) {
           $CRLFile = lonssl::CRLFile();
           $crlchecked{$clientname} = 1;
       }
   
     my $SSLSocket = lonssl::PromoteServerSocket($Socket,      my $SSLSocket = lonssl::PromoteServerSocket($Socket,
  $CACertificate,   $CACertificate,
  $Certificate,   $Certificate,
  $KeyFile);   $KeyFile,
    $clientname,
                                                   $CRLFile,
                                                   $clientversion);
     if(! ($SSLSocket) ) { # SSL socket promotion failed.      if(! ($SSLSocket) ) { # SSL socket promotion failed.
  my $err = lonssl::LastError();   my $err = lonssl::LastError();
  &logthis("<font color=\"red\"> CRITICAL "   &logthis("<font color=\"red\"> CRITICAL "
Line 779  sub ConfigFileFromSelector { Line 801  sub ConfigFileFromSelector {
     my $selector   = shift;      my $selector   = shift;
     my $tablefile;      my $tablefile;
   
     my $tabledir = $perlvar{'lonTabDir'}.'/';      if ($selector eq 'loncapaCAcrl') {
     if (($selector eq "hosts") || ($selector eq "domain") ||           my $tabledir = $perlvar{'lonCertificateDirectory'};
         ($selector eq "dns_hosts") || ($selector eq "dns_domain")) {          if (-d $tabledir) {
  $tablefile =  $tabledir.$selector.'.tab';              $tablefile =  $tabledir.'/'.$selector.'.pem';
           }
       } else {
           my $tabledir = $perlvar{'lonTabDir'}.'/';
           if (($selector eq "hosts") || ($selector eq "domain") || 
               ($selector eq "dns_hosts") || ($selector eq "dns_domain")) {
       $tablefile =  $tabledir.$selector.'.tab';
           }
     }      }
     return $tablefile;      return $tablefile;
 }  }
Line 806  sub PushFile { Line 835  sub PushFile {
     my ($command, $filename, $contents) = split(":", $request, 3);      my ($command, $filename, $contents) = split(":", $request, 3);
     &Debug("PushFile");      &Debug("PushFile");
           
     #  At this point in time, pushes for only the following tables are      #  At this point in time, pushes for only the following tables and
     #  supported:      #  CRL file are supported:
     #   hosts.tab  ($filename eq host).      #   hosts.tab  ($filename eq host).
     #   domain.tab ($filename eq domain).      #   domain.tab ($filename eq domain).
     #   dns_hosts.tab ($filename eq dns_host).      #   dns_hosts.tab ($filename eq dns_host).
     #   dns_domain.tab ($filename eq dns_domain).       #   dns_domain.tab ($filename eq dns_domain).
       #   loncapaCAcrl.pem ($filename eq loncapaCAcrl).
     # Construct the destination filename or reject the request.      # Construct the destination filename or reject the request.
     #      #
     # lonManage is supposed to ensure this, however this session could be      # lonManage is supposed to ensure this, however this session could be
Line 832  sub PushFile { Line 862  sub PushFile {
   
     if($filename eq "host") {      if($filename eq "host") {
  $contents = AdjustHostContents($contents);   $contents = AdjustHostContents($contents);
     } elsif ($filename eq 'dns_host' || $filename eq 'dns_domain') {      } elsif (($filename eq 'dns_host') || ($filename eq 'dns_domain') ||
                ($filename eq 'loncapaCAcrl')) {
         if ($contents eq '') {          if ($contents eq '') {
             &logthis('<font color="red"> Pushfile: unable to install '              &logthis('<font color="red"> Pushfile: unable to install '
                     .$tablefile." - no data received from push. </font>");                      .$tablefile." - no data received from push. </font>");
Line 843  sub PushFile { Line 874  sub PushFile {
             if ($managers{$clientip} eq $clientname) {              if ($managers{$clientip} eq $clientname) {
                 my $clientprotocol = $Apache::lonnet::protocol{$clientname};                  my $clientprotocol = $Apache::lonnet::protocol{$clientname};
                 $clientprotocol = 'http' if ($clientprotocol ne 'https');                  $clientprotocol = 'http' if ($clientprotocol ne 'https');
                 my $url = '/adm/'.$filename;                  my $url;
                 $url =~ s{_}{/};                  if ($filename eq 'loncapaCAcrl') {
                       $url = '/adm/dns/loncapaCRL';
                   } else {
                       $url = '/adm/'.$filename;
                       $url =~ s{_}{/};
                   }
                 my $request=new HTTP::Request('GET',"$clientprotocol://$clienthost$url");                  my $request=new HTTP::Request('GET',"$clientprotocol://$clienthost$url");
                 my $response = LONCAPA::LWPReq::makerequest($clientname,$request,'',\%perlvar,60,0);                  my $response = LONCAPA::LWPReq::makerequest($clientname,$request,'',\%perlvar,60,0);
                 if ($response->is_error()) {                  if ($response->is_error()) {
Line 1606  sub du2_handler { Line 1642  sub du2_handler {
 #  #
 #    1. for a directory, and the path does not begin with one of:  #    1. for a directory, and the path does not begin with one of:
 #        (a) /home/httpd/html/res/<domain>  #        (a) /home/httpd/html/res/<domain>
 #        (b) /home/httpd/html/res/userfiles/  #        (b) /home/httpd/html/userfiles/
 #        (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles  #        (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
 #    or is:  #    or is:
 #  #
 #    2. for a file, and the path (after prepending) does not begin with:  #    2. for a file, and the path (after prepending) does not begin with one of:
 #    /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/  #        (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
   #        (b) /home/httpd/html/res/<domain>/<username>/
   #        (c) /home/httpd/html/userfiles/<domain>/<username>/
 #  #
 #    the response will be "refused".  #    the response will be "refused".
 #  #
Line 1642  sub ls_handler { Line 1680  sub ls_handler {
     }      }
     if (-e $ulsdir) {      if (-e $ulsdir) {
  if(-d $ulsdir) {   if(-d $ulsdir) {
             unless (($ulsdir =~ m{/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||              unless (($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||
                     ($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/userfiles/})) {                      ($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles})) {
                 &Failure($client,"refused\n",$userinput);                  &Failure($client,"refused\n",$userinput);
                 return 1;                  return 1;
             }              }
Line 1670  sub ls_handler { Line 1708  sub ls_handler {
  closedir(LSDIR);   closedir(LSDIR);
     }      }
  } else {   } else {
             unless ($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/}) {              unless (($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) ||
                       ($ulsdir =~ m{^/home/httpd/html/(?:res|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/})) {
                 &Failure($client,"refused\n",$userinput);                  &Failure($client,"refused\n",$userinput);
                 return 1;                  return 1;
             }              }
Line 1703  sub ls_handler { Line 1742  sub ls_handler {
 #  #
 #    1. for a directory, and the path does not begin with one of:  #    1. for a directory, and the path does not begin with one of:
 #        (a) /home/httpd/html/res/<domain>  #        (a) /home/httpd/html/res/<domain>
 #        (b) /home/httpd/html/res/userfiles/  #        (b) /home/httpd/html/userfiles/
 #        (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles  #        (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
 #    or is:  #    or is:
 #  #
 #    2. for a file, and the path (after prepending) does not begin with:  #    2. for a file, and the path (after prepending) does not begin with one of:
 #    /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/  #        (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
   #        (b) /home/httpd/html/res/<domain>/<username>/
   #        (c) /home/httpd/html/userfiles/<domain>/<username>/
 #  #
 #    the response will be "refused".  #    the response will be "refused".
 #  #
Line 1738  sub ls2_handler { Line 1779  sub ls2_handler {
     }      }
     if (-e $ulsdir) {      if (-e $ulsdir) {
         if(-d $ulsdir) {          if(-d $ulsdir) {
             unless (($ulsdir =~ m{/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||              unless (($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||
                     ($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/userfiles/})) {                      ($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles})) {
                 &Failure($client,"refused\n","$userinput");                  &Failure($client,"refused\n","$userinput");
                 return 1;                  return 1;
             }              }
Line 1767  sub ls2_handler { Line 1808  sub ls2_handler {
                 closedir(LSDIR);                  closedir(LSDIR);
             }              }
         } else {          } else {
             unless ($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/}) {              unless (($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) ||
                       ($ulsdir =~ m{^/home/httpd/html/(?:res|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/})) {
                 &Failure($client,"refused\n",$userinput);                  &Failure($client,"refused\n",$userinput);
                 return 1;                  return 1;
             }              }
Line 1792  sub ls2_handler { Line 1834  sub ls2_handler {
 #  #
 #    1. for a directory, and the path does not begin with one of:  #    1. for a directory, and the path does not begin with one of:
 #        (a) /home/httpd/html/res/<domain>  #        (a) /home/httpd/html/res/<domain>
 #        (b) /home/httpd/html/res/userfiles/  #        (b) /home/httpd/html/userfiles/
 #        (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles  #        (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
 #        (d) /home/httpd/html/priv/<domain>/ and client is the homeserver  #        (d) /home/httpd/html/priv/<domain> and client is the homeserver
 #  #
 #    or is:  #    or is:
 #  #
 #    2. for a file, and the path (after prepending) does not begin with:  #    2. for a file, and the path (after prepending) does not begin with one of:
 #    /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/  #        (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
   #        (b) /home/httpd/html/res/<domain>/<username>/
   #        (c) /home/httpd/html/userfiles/<domain>/<username>/
   #        (d) /home/httpd/html/priv/<domain>/<username>/ and client is the homeserver
 #  #
 #    the response will be "refused".  #    the response will be "refused".
 #  #
Line 1873  sub ls3_handler { Line 1918  sub ls3_handler {
     my $rights;      my $rights;
     my $ulsout='';      my $ulsout='';
     my $ulsfn;      my $ulsfn;
   
       my ($crscheck,$toplevel,$currdom,$currnum,$skip);
       unless ($islocal) {
           my ($major,$minor) = split(/\./,$clientversion);
           if (($major < 2) || ($major == 2 && $minor < 12)) {
               $crscheck = 1;
           }
       }
     if (-e $ulsdir) {      if (-e $ulsdir) {
         if(-d $ulsdir) {          if(-d $ulsdir) {
             unless (($getpropath) || ($getuserdir) ||              unless (($getpropath) || ($getuserdir) ||
                     ($ulsdir =~ m{/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||                      ($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||
                     ($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/userfiles/}) ||                      ($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles}) ||
                     (($ulsdir =~ m{/home/httpd/html/priv/$LONCAPA::match_domain/}) && ($islocal))) {                      (($ulsdir =~ m{^/home/httpd/html/priv/$LONCAPA::match_domain}) && ($islocal))) {
                 &Failure($client,"refused\n",$userinput);                  &Failure($client,"refused\n",$userinput);
                 return 1;                  return 1;
             }              }
             if (opendir(LSDIR,$ulsdir)) {              if (($crscheck) &&
                   ($ulsdir =~ m{^/home/httpd/html/res/($LONCAPA::match_domain)(/?$|/$LONCAPA::match_courseid)})) {
                   ($currdom,my $posscnum) = ($1,$2);
                   if (($posscnum eq '') || ($posscnum eq '/')) {
                       $toplevel = 1;
                   } else {
                       $posscnum =~ s{^/+}{};
                       if (&LONCAPA::Lond::is_course($currdom,$posscnum)) {
                           $skip = 1;
                       }
                   }
               }
               if ((!$skip) && (opendir(LSDIR,$ulsdir))) {
                 while ($ulsfn=readdir(LSDIR)) {                  while ($ulsfn=readdir(LSDIR)) {
                       if (($crscheck) && ($toplevel) && ($currdom ne '') &&
                           ($ulsfn =~ /^$LONCAPA::match_courseid$/) && (-d "$ulsdir/$ulsfn")) {
                           if (&LONCAPA::Lond::is_course($currdom,$ulsfn)) {
                               next;
                           }
                       }
                     undef($obs);                      undef($obs);
                     undef($rights);                      undef($rights);
                     my @ulsstats=stat($ulsdir.'/'.$ulsfn);                      my @ulsstats=stat($ulsdir.'/'.$ulsfn);
Line 1907  sub ls3_handler { Line 1978  sub ls3_handler {
             }              }
         } else {          } else {
             unless (($getpropath) || ($getuserdir) ||              unless (($getpropath) || ($getuserdir) ||
                     ($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/})) {                      ($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) ||
                       ($ulsdir =~ m{^/home/httpd/html/(?:res|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/}) ||
                       (($ulsdir =~ m{^/home/httpd/html/priv/$LONCAPA::match_domain/$LONCAPA::match_name/}) && ($islocal))) {
                 &Failure($client,"refused\n",$userinput);                  &Failure($client,"refused\n",$userinput);
                 return 1;                  return 1;
             }              }
Line 1963  sub read_lonnet_global { Line 2036  sub read_lonnet_global {
                 }                  }
                 if ($what eq 'perlvar') {                  if ($what eq 'perlvar') {
                     if (!exists($packagevars{$what}{'lonBalancer'})) {                      if (!exists($packagevars{$what}{'lonBalancer'})) {
                         if ($dist =~ /^(centos|rhes|fedora|scientific)/) {                          if ($dist =~ /^(centos|rhes|fedora|scientific|oracle|rocky|alma)/) {
                             my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');                              my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');
                             if (ref($othervarref) eq 'HASH') {                              if (ref($othervarref) eq 'HASH') {
                                 $items->{'lonBalancer'} = $othervarref->{'lonBalancer'};                                  $items->{'lonBalancer'} = $othervarref->{'lonBalancer'};
Line 2059  sub server_distarch_handler { Line 2132  sub server_distarch_handler {
 sub server_certs_handler {  sub server_certs_handler {
     my ($cmd,$tail,$client) = @_;      my ($cmd,$tail,$client) = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my $result;      my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
     my $result = &LONCAPA::Lond::server_certs(\%perlvar);      my $result = &LONCAPA::Lond::server_certs(\%perlvar,$perlvar{'lonHostID'},$hostname);
     &Reply($client,\$result,$userinput);      &Reply($client,\$result,$userinput);
     return;      return;
 }  }
Line 2281  sub change_password_handler { Line 2354  sub change_password_handler {
     }      }
     if($validated) {      if($validated) {
  my $realpasswd  = &get_auth_type($udom, $uname); # Defined since authd.   my $realpasswd  = &get_auth_type($udom, $uname); # Defined since authd.
   
  my ($howpwd,$contentpwd)=split(/:/,$realpasswd);   my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
           my $notunique;
  if ($howpwd eq 'internal') {   if ($howpwd eq 'internal') {
     &Debug("internal auth");      &Debug("internal auth");
             my $ncpass = &hash_passwd($udom,$npass);              my $ncpass = &hash_passwd($udom,$npass);
     if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {              my (undef,$method,@rest) = split(/!/,$contentpwd);
               if ($method eq 'bcrypt') {
                   my %passwdconf = &Apache::lonnet::get_passwdconf($udom);
                   if (($passwdconf{'numsaved'}) && ($passwdconf{'numsaved'} =~ /^\d+$/)) {
                       my @oldpasswds;
                       my $userpath = &propath($udom,$uname);
                       my $fullpath = $userpath.'/oldpasswds';
                       if (-d $userpath) {
                           my @oldfiles;
                           if (-e $fullpath) {
                               if (opendir(my $dir,$fullpath)) {
                                   (@oldfiles) = grep(/^\d+$/,readdir($dir));
                                   closedir($dir);
                               }
                               if (@oldfiles) {
                                   @oldfiles = sort { $b <=> $a } (@oldfiles);
                                   my $numremoved = 0;
                                   for (my $i=0; $i<@oldfiles; $i++) {
                                       if ($i>=$passwdconf{'numsaved'}) {
                                           if (-f "$fullpath/$oldfiles[$i]") {
                                               if (unlink("$fullpath/$oldfiles[$i]")) {
                                                   $numremoved ++;
                                               }
                                           }
                                       } elsif (open(my $fh,'<',"$fullpath/$oldfiles[$i]")) {
                                           while (my $line = <$fh>) {
                                               push(@oldpasswds,$line);
                                           }
                                           close($fh);
                                       }
                                   }
                                   if ($numremoved) {
                                       &logthis("unlinked $numremoved old password files for $uname:$udom");
                                   }
                               }
                           }
                           push(@oldpasswds,$contentpwd);
                           foreach my $item (@oldpasswds) {
                               my (undef,$method,@rest) = split(/!/,$item);
                               if ($method eq 'bcrypt') {
                                   my $result = &hash_passwd($udom,$npass,@rest);
                                   if ($result eq $item) {
                                       $notunique = 1;
                                       last;
                                   }
                               }
                           }
                           unless ($notunique) {
                               unless (-e $fullpath) {
                                   if (&mkpath("$fullpath/")) {
                                       chmod(0700,$fullpath);
                                   }
                               }
                               if (-d $fullpath) {
                                   my $now = time;
                                   if (open(my $fh,'>',"$fullpath/$now")) {
                                       print $fh $contentpwd;
                                       close($fh);
                                       chmod(0400,"$fullpath/$now");
                                   }
                               }
                           }
                       }
                   }
               }
               if ($notunique) {
                   my $msg="Result of password change for $uname:$udom - password matches one used before";
                   if ($lonhost) {
                       $msg .= " - request originated from: $lonhost";
                   }
                   &logthis($msg);
                   &Reply($client, "prioruse\n", $userinput);
       } elsif (&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
  my $msg="Result of password change for $uname: pwchange_success";   my $msg="Result of password change for $uname: pwchange_success";
                 if ($lonhost) {                  if ($lonhost) {
                     $msg .= " - request originated from: $lonhost";                      $msg .= " - request originated from: $lonhost";
Line 2303  sub change_password_handler { Line 2448  sub change_password_handler {
     my $result = &change_unix_password($uname, $npass);      my $result = &change_unix_password($uname, $npass);
             if ($result eq 'ok') {              if ($result eq 'ok') {
                 &update_passwd_history($uname,$udom,$howpwd,$context);                  &update_passwd_history($uname,$udom,$howpwd,$context);
              }              }
     &logthis("Result of password change for $uname: ".      &logthis("Result of password change for $uname: ".
      $result);       $result);
     &Reply($client, \$result, $userinput);      &Reply($client, \$result, $userinput);
Line 2314  sub change_password_handler { Line 2459  sub change_password_handler {
     #      #
     &Failure( $client, "auth_mode_error\n", $userinput);      &Failure( $client, "auth_mode_error\n", $userinput);
  }     }  
   
     } else {      } else {
  if ($failure eq '') {   if ($failure eq '') {
     $failure = 'non_authorized';      $failure = 'non_authorized';
Line 2591  sub update_resource_handler { Line 2735  sub update_resource_handler {
  my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
  my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");   my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  my $response;   my $response;
 # FIXME: cannot replicate files that take more than two minutes to transfer?  # FIXME: cannot replicate files that take more than two minutes to transfer -- needs checking now 1200s timeout used
 # alarm(120);  # for LWP request.
 # FIXME: this should use the LWP mechanism, not internal alarms.   my $request=new HTTP::Request('GET',"$remoteurl");
                 alarm(1200);                  $response=&LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,0,1);
  {  
     my $request=new HTTP::Request('GET',"$remoteurl");  
                     $response=&LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,0,1);  
  }  
  alarm(0);  
  if ($response->is_error()) {   if ($response->is_error()) {
 # FIXME: we should probably clean up here instead of just whine                      my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
     unlink($transname);                      &devalidate_meta_cache($fname);
                       if (-e $transname) {
                           unlink($transname);
                       }
                       unlink($fname);
     my $message=$response->status_line;      my $message=$response->status_line;
     &logthis("LWP GET: $message for $fname ($remoteurl)");      &logthis("LWP GET: $message for $fname ($remoteurl)");
  } else {   } else {
     if ($remoteurl!~/\.meta$/) {      if ($remoteurl!~/\.meta$/) {
 # FIXME: isn't there an internal LWP mechanism for this?   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
  alarm(120);                          my $mresponse = &LONCAPA::LWPReq::makerequest($clientname,$mrequest,$fname.'.meta',\%perlvar,120,0,1);
  {   if ($mresponse->is_error()) {
     my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');      unlink($fname.'.meta');
                             my $mresponse = &LONCAPA::LWPReq::makerequest($clientname,$mrequest,$fname.'.meta',\%perlvar,120,0,1);  
     if ($mresponse->is_error()) {  
  unlink($fname.'.meta');  
     }  
  }   }
  alarm(0);  
     }      }
                     # we successfully transfered, copy file over to real name                      # we successfully transfered, copy file over to real name
     rename($transname,$fname);      rename($transname,$fname);
Line 2686  sub fetch_user_file_handler { Line 2824  sub fetch_user_file_handler {
  my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;   my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
  my $response;   my $response;
  Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");   Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
  alarm(1200);   my $request=new HTTP::Request('GET',"$remoteurl");
  {          my $verifycert = 1;
     my $request=new HTTP::Request('GET',"$remoteurl");          my @machine_ids = &Apache::lonnet::current_machine_ids();
             my $verifycert = 1;          if (grep(/^\Q$clientname\E$/,@machine_ids)) {
             my @machine_ids = &Apache::lonnet::current_machine_ids();              $verifycert = 0;
             if (grep(/^\Q$clientname\E$/,@machine_ids)) {          }
                 $verifycert = 0;          $response = &LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,$verifycert);
             }  
             $response = &LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,$verifycert);  
  }  
  alarm(0);  
  if ($response->is_error()) {   if ($response->is_error()) {
     unlink($transname);      unlink($transname);
     my $message=$response->status_line;      my $message=$response->status_line;
Line 2905  sub user_has_session_handler { Line 3039  sub user_has_session_handler {
 }  }
 &register_handler("userhassession", \&user_has_session_handler, 0,1,0);  &register_handler("userhassession", \&user_has_session_handler, 0,1,0);
   
   sub del_usersession_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $result;
       my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
       if (($udom =~ /^$LONCAPA::match_domain$/) && ($uname =~ /^$LONCAPA::match_username$/)) {
           my $lonidsdir = $perlvar{'lonIDsDir'};
           if (-d $lonidsdir) {
               if (opendir(DIR,$lonidsdir)) {
                   my $filename;
                   while ($filename=readdir(DIR)) {
                       if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/) {
                           if (tie(my %oldenv,'GDBM_File',"$lonidsdir/$filename",
                                   &GDBM_READER(),0640)) {
                               my $linkedfile;
                               if (exists($oldenv{'user.linkedenv'})) {
                                   $linkedfile = $oldenv{'user.linkedenv'};
                               }
                               untie(%oldenv);
                               $result = unlink("$lonidsdir/$filename");
                               if ($result) {
                                   if ($linkedfile =~ /^[a-f0-9]+_linked$/) {
                                       if (-l "$lonidsdir/$linkedfile.id") {
                                           unlink("$lonidsdir/$linkedfile.id");
                                       }
                                   }
                               }
                           } else {
                               $result = unlink("$lonidsdir/$filename");
                           }
                           last;
                       }
                   }
               }
           }
           if ($result == 1) {
               &Reply($client, "$result\n", "$cmd:$tail");
           } else {
               &Reply($client, "not_found\n", "$cmd:$tail");
           }
       } else {
           &Failure($client, "invalid_user\n", "$cmd:$tail");
       }
       return 1;
   }
   
   &register_handler("delusersession", \&del_usersession_handler, 0,1,0);
   
 #  #
 #  Authenticate access to a user file by checking that the token the user's   #  Authenticate access to a user file by checking that the token the user's 
 #  passed also exists in their session file  #  passed also exists in their session file
Line 3648  sub dump_with_regexp { Line 3830  sub dump_with_regexp {
 }  }
 &register_handler("dump", \&dump_with_regexp, 0, 1, 0);  &register_handler("dump", \&dump_with_regexp, 0, 1, 0);
   
   #
   #  Process the encrypted dump request. Original call should
   #  be from lonnet::dump() with seventh arg ($encrypt) set to
   #  1, to ensure that both request and response are encrypted.
   #
   #  Parameters:
   #     $cmd               - Command keyword of request (edump).
   #     $tail              - Tail of the command.
   #                          See &dump_with_regexp for more
   #                          information about this.
   #     $client            - File open on the client.
   #  Returns:
   #     1      - Continue processing
   #     0      - server should exit.
   #
   
   sub encrypted_dump_with_regexp {
       my ($cmd, $tail, $client) = @_;
       my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion);
   
       if ($res =~ /^error:/) {
           Failure($client, \$res, "$cmd:$tail");
       } else {
           if ($cipher) {
               my $cmdlength=length($res);
               $res.="         ";
               my $encres='';
               for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
                   $encres.= unpack("H16",
                                    $cipher->encrypt(substr($res,
                                                            $encidx,
                                                            8)));
               }
               &Reply( $client,"enc:$cmdlength:$encres\n","$cmd:$tail");
           } else {
               &Failure( $client, "error:no_key\n","$cmd:$tail");
           }
       }
   }
   &register_handler("edump", \&encrypted_dump_with_regexp, 0, 1, 0);
   
 #  Store a set of key=value pairs associated with a versioned name.  #  Store a set of key=value pairs associated with a versioned name.
 #  #
 #  Parameters:  #  Parameters:
Line 4696  sub course_lastaccess_handler { Line 4919  sub course_lastaccess_handler {
 }  }
 &register_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);  &register_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);
   
   sub course_sessions_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($cdom,$cnum,$lastactivity) = split(':',$tail);
       my $dbsuffix = '_'.$cdom.'_'.$cnum.'.db';
       my (%sessions,$qresult);
       my $now=time;
       if (opendir(DIR,$perlvar{'lonIDsDir'})) {
           my $filename;
           while ($filename=readdir(DIR)) {
               next if ($filename=~/^\./);
               next if ($filename=~/^publicuser_/);
               next if ($filename=~/^[a-f0-9]+_(linked|lti_\d+)\.id$/);
               if ($filename =~ /^($LONCAPA::match_username)_\d+_($LONCAPA::match_domain)_/) {
                   my ($uname,$udom) = ($1,$2);
                   next unless (-e "$perlvar{'lonDaemons'}/tmp/$uname$dbsuffix");
                   my $mtime = (stat("$perlvar{'lonIDsDir'}/$filename"))[9];
                   if ($lastactivity < 0) {
                       next if ($mtime-$now > $lastactivity);
                   } else {
                       next if ($now-$mtime > $lastactivity);
                   }
                   $sessions{$uname.':'.$udom} = $mtime;
               }
           }
           closedir(DIR); 
       }
       foreach my $user (keys(%sessions)) {
           $qresult.=&escape($user).'='.$sessions{$user}.'&';
       }
       if ($qresult) {
           chop($qresult);
       }
       &Reply($client, \$qresult, $userinput);
       return 1;
   }
   &register_handler("coursesessions",\&course_sessions_handler, 0, 1, 0);
   
 #  #
 # Puts an unencrypted entry in a namespace db file at the domain level   # Puts an unencrypted entry in a namespace db file at the domain level 
 #  #
Line 4860  sub del_domain_handler { Line 5121  sub del_domain_handler {
 # domain directory.  # domain directory.
 #  #
 # Parameters:  # Parameters:
 #   $cmd             - Command request keyword (get).  #   $cmd             - Command request keyword (getdom).
 #   $tail            - Tail of the command.  This is a colon separated list  #   $tail            - Tail of the command.  This is a colon separated list
 #                      consisting of the domain and the 'namespace'   #                      consisting of the domain and the 'namespace' 
 #                      which selects the gdbm file to do the lookup in,  #                      which selects the gdbm file to do the lookup in,
Line 4877  sub del_domain_handler { Line 5138  sub del_domain_handler {
 sub get_domain_handler {  sub get_domain_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$namespace,$what)=split(/:/,$tail,3);      my ($udom,$namespace,$what)=split(/:/,$tail,3);
     chomp($what);  
     if ($namespace =~ /^enc/) {      if ($namespace =~ /^enc/) {
         &Failure( $client, "refused\n", $userinput);          &Failure( $client, "refused\n", $userinput);
     } else {      } else {
         my @queries=split(/\&/,$what);          my $res = LONCAPA::Lond::get_dom($userinput);
         my $qresult='';          if ($res =~ /^error:/) {
         my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER());              &Failure($client, \$res, $userinput);
         if ($hashref) {  
             for (my $i=0;$i<=$#queries;$i++) {  
                 $qresult.="$hashref->{$queries[$i]}&";  
             }  
             if (&untie_domain_hash($hashref)) {  
                 $qresult=~s/\&$//;  
                 &Reply($client, \$qresult, $userinput);  
             } else {  
                 &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".  
                           "while attempting getdom\n",$userinput);  
             }  
         } else {          } else {
             &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".              &Reply($client, \$res, $userinput);
                      "while attempting getdom\n",$userinput);  
         }          }
     }      }
   
Line 4914  sub encrypted_get_domain_handler { Line 5161  sub encrypted_get_domain_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$namespace,$what)=split(/:/,$tail,3);      my $res = LONCAPA::Lond::get_dom($userinput);
     chomp($what);      if ($res =~ /^error:/) {
     my @queries=split(/\&/,$what);          &Failure($client, \$res, $userinput);
     my $qresult='';      } else {
     my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER());          if ($cipher) {
     if ($hashref) {              my $cmdlength=length($res);
         for (my $i=0;$i<=$#queries;$i++) {              $res.="         ";
             $qresult.="$hashref->{$queries[$i]}&";              my $encres='';
         }              for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
         if (&untie_domain_hash($hashref)) {                  $encres.= unpack("H16",
             $qresult=~s/\&$//;                                   $cipher->encrypt(substr($res,
             if ($cipher) {                                                           $encidx,
                 my $cmdlength=length($qresult);                                                           8)));
                 $qresult.="         ";  
                 my $encqresult='';  
                 for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {  
                     $encqresult.= unpack("H16",  
                                          $cipher->encrypt(substr($qresult,  
                                                                  $encidx,  
                                                                  8)));  
                 }  
                 &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);  
             } else {  
                 &Failure( $client, "error:no_key\n", $userinput);  
             }              }
               &Reply( $client,"enc:$cmdlength:$encres\n",$userinput);
         } else {          } else {
             &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".              &Failure( $client, "error:no_key\n",$userinput);
                       "while attempting egetdom\n",$userinput);  
         }          }
     } else {  
         &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
                  "while attempting egetdom\n",$userinput);  
     }      }
     return 1;      return 1;
 }  }
Line 5376  sub tmp_put_handler { Line 5609  sub tmp_put_handler {
     }      }
     my ($id,$store);      my ($id,$store);
     $tmpsnum++;      $tmpsnum++;
     if (($context eq 'resetpw') || ($context eq 'createaccount')) {      my $numtries = 0;
         $id = &md5_hex(&md5_hex(time.{}.rand().$$));      my $execdir=$perlvar{'lonDaemons'};
       if (($context eq 'resetpw') || ($context eq 'createaccount') ||
           ($context eq 'sso') || ($context eq 'link') || ($context eq 'retry')) {
           $id = &md5_hex(&md5_hex(time.{}.rand().$$.$tmpsnum));
           while ((-e "$execdir/tmp/$id.tmp") && ($numtries <10)) {
               undef($id);
               $id = &md5_hex(&md5_hex(time.{}.rand().$$.$tmpsnum));
               $numtries ++;
           }
     } else {      } else {
         $id = $$.'_'.$clientip.'_'.$tmpsnum;          $id = $$.'_'.$clientip.'_'.$tmpsnum;
     }      }
     $id=~s/\W/\_/g;      $id=~s/\W/\_/g;
     $record=~s/\n//g;      $record=~s/\n//g;
     my $execdir=$perlvar{'lonDaemons'};      if (($id ne '') &&
     if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {          ($store=IO::File->new(">$execdir/tmp/$id.tmp"))) {
  print $store $record;   print $store $record;
  close $store;   close $store;
  &Reply($client, \$id, $userinput);   &Reply($client, \$id, $userinput);
Line 5467  sub tmp_del_handler { Line 5708  sub tmp_del_handler {
 &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);  &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);
   
 #  #
   #  Process the updatebalcookie command.  This command updates a
   #  cookie in the lonBalancedir directory on a load balancer node.
   #
   # Parameters:
   #   $cmd      - Command that got us here.
   #   $tail     - Tail of the request (escaped cookie: escaped current entry)
   #
   #   $client   - socket open on the client process.
   #
   # Returns:
   #   1     - Indicating processing should continue.
   # Side Effects:
   #   A cookie file is updated from the lonBalancedir directory
   #   A reply is sent to the client.
   #
   sub update_balcookie_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput= "$cmd:$tail";
       chomp($tail);
       my ($cookie,$lastentry) = map { &unescape($_) } (split(/:/,$tail));
   
       my $updatedone;
       if ($cookie =~ /^$LONCAPA::match_domain\_$LONCAPA::match_username\_[a-f0-9]{32}$/) {
           my $execdir=$perlvar{'lonBalanceDir'};
           if (-e "$execdir/$cookie.id") {
               my $doupdate;
               if (open(my $fh,'<',"$execdir/$cookie.id")) {
                   while (my $line = <$fh>) {
                       chomp($line);
                       if ($line eq $lastentry) {
                           $doupdate = 1;
                           last;
                       }
                   }
                   close($fh);
               }
               if ($doupdate) {
                   if (open(my $fh,'>',"$execdir/$cookie.id")) {
                       print $fh $clientname;
                       close($fh);
                       $updatedone = 1;
                   }
               }
           }
       }
       if ($updatedone) {
           &Reply($client, "ok\n", $userinput);
       } else {
           &Failure( $client, "error: ".($!+0)."file update failed ".
                     "while attempting updatebalcookie\n", $userinput);
       }
       return 1;
   }
   &register_handler("updatebalcookie", \&update_balcookie_handler, 0, 1, 0);
   
   #
   #  Process the delbalcookie command. This command deletes a balancer
   #  cookie in the lonBalancedir directory on a load balancer node.
   #
   # Parameters:
   #   $cmd      - Command that got us here.
   #   $cookie   - Cookie to be deleted.
   #   $client   - socket open on the client process.
   #
   # Returns:
   #   1     - Indicating processing should continue.
   # Side Effects:
   #   A cookie file is deleted from the lonBalancedir directory
   #   A reply is sent to the client.
   sub del_balcookie_handler {
       my ($cmd, $cookie, $client) = @_;
   
       my $userinput= "$cmd:$cookie";
   
       chomp($cookie);
       $cookie = &unescape($cookie);
       my $deleted = '';
       if ($cookie =~ /^$LONCAPA::match_domain\_$LONCAPA::match_username\_[a-f0-9]{32}$/) {
           my $execdir=$perlvar{'lonBalanceDir'};
           if (-e "$execdir/$cookie.id") {
               if (open(my $fh,'<',"$execdir/$cookie.id")) {
                   my $dodelete;
                   while (my $line = <$fh>) {
                       chomp($line);
                       if ($line eq $clientname) {
                           $dodelete = 1;
                           last;
                       }
                   }
                   close($fh);
                   if ($dodelete) {
                       if (unlink("$execdir/$cookie.id")) {
                           $deleted = 1;
                       }
                   }
               }
           }
       }
       if ($deleted) {
           &Reply($client, "ok\n", $userinput);
       } else {
           &Failure( $client, "error: ".($!+0)."Unlinking cookie file Failed ".
                     "while attempting delbalcookie\n", $userinput);
       }
       return 1;
   }
   &register_handler("delbalcookie", \&del_balcookie_handler, 0, 1, 0);
   
   #
 #   Processes the setannounce command.  This command  #   Processes the setannounce command.  This command
 #   creates a file named announce.txt in the top directory of  #   creates a file named announce.txt in the top directory of
 #   the documentn root and sets its contents.  The announce.txt file is  #   the documentn root and sets its contents.  The announce.txt file is
Line 5649  sub validate_instcode_handler { Line 6000  sub validate_instcode_handler {
 }  }
 &register_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0);  &register_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0);
   
   #
   #  Validate co-owner for cross-listed institutional code and
   #  institutional course code itself used for a LON-CAPA course.
   #
   # Formal Parameters:
   #   $cmd          - The command request that got us dispatched.
   #   $tail         - The tail of the command.  In this case,
   #                   this is a colon separated string containing:
   #      $dom            - Course's LON-CAPA domain
   #      $instcode       - Institutional course code for the course
   #      $inst_xlist     - Institutional course Id for the crosslisting
   #      $coowner        - Username of co-owner
   #      (values for all but $dom have been escaped). 
   #
   #   $client       - Socket open on the client.
   # Returns:
   #    1           - Indicating processing should continue.
   #
   sub validate_instcrosslist_handler  {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($dom,$instcode,$inst_xlist,$coowner) = split(/:/,$tail);
       $instcode = &unescape($instcode);
       $inst_xlist = &unescape($inst_xlist);
       $coowner = &unescape($coowner);
       my $outcome = &localenroll::validate_crosslist_access($dom,$instcode,
                                                             $inst_xlist,$coowner);
       &Reply($client, \$outcome, $userinput);
   
       return 1;
   }
   &register_handler("autovalidateinstcrosslist", \&validate_instcrosslist_handler, 0, 1, 0);
   
 #   Get the official sections for which auto-enrollment is possible.  #   Get the official sections for which auto-enrollment is possible.
 #   Since the admin people won't know about 'unofficial sections'   #   Since the admin people won't know about 'unofficial sections' 
 #   we cannot auto-enroll on them.  #   we cannot auto-enroll on them.
Line 5745  sub validate_course_section_handler { Line 6129  sub validate_course_section_handler {
 # Formal Parameters:  # Formal Parameters:
 #    $cmd     - The command request that got us dispatched.  #    $cmd     - The command request that got us dispatched.
 #    $tail    - The tail of the command.   In this case this is a colon separated  #    $tail    - The tail of the command.   In this case this is a colon separated
 #               set of words that will be split into:  #               set of values that will be split into:
 #               $inst_class  - Institutional code for the specific class section     #               $inst_class  - Institutional code for the specific class section   
 #               $courseowner - The escaped username:domain of the course owner   #               $ownerlist   - An escaped comma-separated list of username:domain 
   #                              of the course owner, and co-owner(s).
 #               $cdom        - The domain of the course from the institution's  #               $cdom        - The domain of the course from the institution's
 #                              point of view.  #                              point of view.
 #    $client  - The socket open on the client.  #    $client  - The socket open on the client.
Line 5772  sub validate_class_access_handler { Line 6157  sub validate_class_access_handler {
 &register_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);  &register_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);
   
 #  #
   #    Modify institutional sections (using customized &instsec_reformat()
   #    routine in localenroll.pm), to either clutter or declutter, for  
   #    purposes of ensuring an institutional course section (string) can
   #    be unambiguously separated into institutional course and section.
   #
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - The tail of the command.   In this case this is a colon separated
   #               set of values that will be split into:
   #               $cdom        - The LON-CAPA domain of the course.
   #               $action      - Either: clutter or declutter
   #                              clutter adds character(s) to eliminate ambiguity
   #                              declutter removes the added characters (e.g., for
   #                              display of the institutional course section string.
   #               $info        - A frozen hash in which keys are: 
   #                              LON-CAPA course number:Institutional course code
   #                              and values are a reference to an array of the
   #                              items to modify -- either institutional sections,
   #                              or institutional course sections (for crosslistings). 
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
   #   
   
   sub instsec_reformat_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($cdom,$action,$info) = split(/:/,$tail);
       my $instsecref = &Apache::lonnet::thaw_unescape($info);
       my ($outcome,$result);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome=&localenroll::instsec_reformat($cdom,$action,$instsecref);
           if ($outcome eq 'ok') {
               if (ref($instsecref) eq 'HASH') {
                   foreach my $key (keys(%{$instsecref})) {
                       $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($instsecref->{$key}).'&';
                   }
                   $result =~ s/\&$//;
               }
           }
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               &Reply( $client, \$result, $userinput);
           } else {
               &Reply($client,\$outcome, $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autoinstsecreformat",\&instsec_reformat_handler, 0, 1, 0);
   
   #
   #   Validate course owner or co-owners(s) access to enrollment data for all sections
   #   and crosslistings for a particular course.
   #
   #
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - The tail of the command.   In this case this is a colon separated
   #               set of values that will be split into:
   #               $ownerlist   - An escaped comma-separated list of username:domain
   #                              of the course owner, and co-owner(s).
   #               $cdom        - The domain of the course from the institution's
   #                              point of view.
   #               $classes     - Frozen hash of institutional course sections and
   #                              crosslistings.
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
   #
   
   sub validate_classes_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($ownerlist,$cdom,$classes) = split(/:/, $tail);
       my $classesref = &Apache::lonnet::thaw_unescape($classes);
       my $owners = &unescape($ownerlist);
       my $result;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           my %validations;
           my $response = &localenroll::check_instclasses($owners,$cdom,$classesref,
                                                          \%validations);
           if ($response eq 'ok') {
               foreach my $key (keys(%validations)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&';
               }
               $result =~ s/\&$//;
           } else {
               $result = 'error';
           }
       };
       if (!$@) {
           &Reply($client, \$result, $userinput);
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autovalidateinstclasses", \&validate_classes_handler, 0, 1, 0);
   
   #
 #   Create a password for a new LON-CAPA user added by auto-enrollment.  #   Create a password for a new LON-CAPA user added by auto-enrollment.
 #   Only used for case where authentication method for new user is localauth  #   Only used for case where authentication method for new user is localauth
 #  #
Line 6805  my $wwwid=getpwnam('www'); Line 7296  my $wwwid=getpwnam('www');
 if ($wwwid!=$<) {  if ($wwwid!=$<) {
    my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";     my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
    my $subj="LON: $currenthostid User ID mismatch";     my $subj="LON: $currenthostid User ID mismatch";
    system("echo 'User ID mismatch.  lond must be run as user www.' |\     system("echo 'User ID mismatch.  lond must be run as user www.' |".
  mailto $emailto -s '$subj' > /dev/null");            " mail -s '$subj' $emailto > /dev/null");
    exit 1;     exit 1;
 }  }
   
Line 6940  sub UpdateHosts { Line 7431  sub UpdateHosts {
   
     my %oldconf = %secureconf;      my %oldconf = %secureconf;
     my %connchange;      my %connchange;
     if (lonssl::Read_Connect_Config(\%secureconf,\%perlvar) eq 'ok') {      if (lonssl::Read_Connect_Config(\%secureconf,\%perlvar,\%crlchecked) eq 'ok') {
         logthis('<font color="blue"> Reloaded SSL connection rules </font>');          logthis('<font color="blue"> Reloaded SSL connection rules and cleared CRL checking history </font>');
     } else {      } else {
         logthis('<font color="yellow"> Failed to reload SSL connection rules </font>');          logthis('<font color="yellow"> Failed to reload SSL connection rules and clear CRL checking history </font>');
     }      }
     if ((ref($oldconf{'connfrom'}) eq 'HASH') && (ref($secureconf{'connfrom'}) eq 'HASH')) {      if ((ref($oldconf{'connfrom'}) eq 'HASH') && (ref($secureconf{'connfrom'}) eq 'HASH')) {
         foreach my $type ('dom','intdom','other') {          foreach my $type ('dom','intdom','other') {
Line 7222  if ($arch eq 'unknown') { Line 7713  if ($arch eq 'unknown') {
     chomp($arch);      chomp($arch);
 }  }
   
 unless (lonssl::Read_Connect_Config(\%secureconf,\%perlvar) eq 'ok') {  unless (lonssl::Read_Connect_Config(\%secureconf,\%perlvar,\%crlchecked) eq 'ok') {
     &logthis('<font color="blue">No connectionrules table. Will fallback to loncapa.conf</font>');      &logthis('<font color="blue">No connectionrules table. Will fallback to loncapa.conf</font>');
 }  }
   
Line 7311  sub make_new_child { Line 7802  sub make_new_child {
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
   
         my $no_ets;          my $no_ets;
         if ($dist =~ /^(?:centos|rhes|scientific)(\d+)$/) {          if ($dist =~ /^(?:centos|rhes|scientific|oracle|rocky|alma)(\d+)$/) {
             if ($1 >= 7) {              if ($1 >= 7) {
                 $no_ets = 1;                  $no_ets = 1;
             }              }
Line 7356  sub make_new_child { Line 7847  sub make_new_child {
     $ConnectionType = "manager";      $ConnectionType = "manager";
     $clientname = $managers{$outsideip};      $clientname = $managers{$outsideip};
  }   }
  my ($clientok,$clientinfoset);   my $clientok;
   
  if ($clientrec || $ismanager) {   if ($clientrec || $ismanager) {
     &status("Waiting for init from $clientip $clientname");      &status("Waiting for init from $clientip $clientname");
Line 7457  sub make_new_child { Line 7948  sub make_new_child {
     }      }
         
  } else {   } else {
                     $clientinfoset = &set_client_info();  
     my $ok = InsecureConnection($client);      my $ok = InsecureConnection($client);
     if($ok) {      if($ok) {
  $clientok = 1;   $clientok = 1;
Line 7495  sub make_new_child { Line 7985  sub make_new_child {
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
     my $keep_going = 1;      my $keep_going = 1;
     my $user_input;      my $user_input;
             unless ($clientinfoset) {  
                 $clientinfoset = &set_client_info();  
             }  
             $clientremoteok = 0;  
             unless ($clientsameinst) {  
                 $clientremoteok = 1;  
                 my $defdom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});  
                 %clientprohibited = &get_prohibited($defdom);  
                 if ($clientintdom) {  
                     my $remsessconf = &get_usersession_config($defdom,'remotesession');  
                     if (ref($remsessconf) eq 'HASH') {  
                         if (ref($remsessconf->{'remote'}) eq 'HASH') {  
                             if (ref($remsessconf->{'remote'}->{'excludedomain'}) eq 'ARRAY') {  
                                 if (grep(/^\Q$clientintdom\E$/,@{$remsessconf->{'remote'}->{'excludedomain'}})) {  
                                     $clientremoteok = 0;  
                                 }  
                             }  
                             if (ref($remsessconf->{'remote'}->{'includedomain'}) eq 'ARRAY') {  
                                 if (grep(/^\Q$clientintdom\E$/,@{$remsessconf->{'remote'}->{'includedomain'}})) {  
                                     $clientremoteok = 1;  
                                 } else {  
                                     $clientremoteok = 0;  
                                 }  
                             }  
                         }  
                     }  
                 }  
             }  
     while(($user_input = get_request) && $keep_going) {      while(($user_input = get_request) && $keep_going) {
  alarm(120);   alarm(120);
  Debug("Main: Got $user_input\n");   Debug("Main: Got $user_input\n");
  $keep_going = &process_request($user_input);   $keep_going = &process_request($user_input);
  alarm(0);   alarm(0);
  &status('Listening to '.$clientname." ($keymode)");      &status('Listening to '.$clientname." ($keymode)");
     }      }
   
 # --------------------------------------------- client unknown or fishy, refuse  # --------------------------------------------- client unknown or fishy, refuse
Line 7544  sub make_new_child { Line 8007  sub make_new_child {
           
     &logthis("<font color='red'>CRITICAL: "      &logthis("<font color='red'>CRITICAL: "
      ."Disconnect from $clientip ($clientname)</font>");           ."Disconnect from $clientip ($clientname)</font>");    
       
       
     # this exit is VERY important, otherwise the child will become      # this exit is VERY important, otherwise the child will become
     # a producer of more and more children, forking yourself into      # a producer of more and more children, forking yourself into
     # process death.      # process death.
Line 7555  sub make_new_child { Line 8018  sub make_new_child {
   
 #  #
 #  Used to determine if a particular client is from the same domain  #  Used to determine if a particular client is from the same domain
 #  as the current server, or from the same internet domain.  #  as the current server, or from the same internet domain, and
   #  also if the client can host sessions for the domain's users.
   #  A hash is populated with keys set to commands sent by the client
   #  which may not be executed for this domain.
 #  #
 #  Optional input -- the client to check for domain and internet domain.  #  Optional input -- the client to check for domain and internet domain.
 #  If not specified, defaults to the package variable: $clientname  #  If not specified, defaults to the package variable: $clientname
 #  #
 #  If called in array context will not set package variables, but will  #  If called in array context will not set package variables, but will
 #  instead return an array of two values - (a) true if client is in the  #  instead return an array of two values - (a) true if client is in the
 #  same domain as the server, and (b) true if client is in the same internet  #  same domain as the server, and (b) true if client is in the same 
 #  domain.  #  internet domain.
 #  #
 #  If called in scalar context, sets package variables for current client:  #  If called in scalar context, sets package variables for current client:
 #  #
 #  $clienthomedom  - LonCAPA domain of homeID for client.  #  $clienthomedom    - LonCAPA domain of homeID for client.
 #  $clientsamedom  - LonCAPA domain same for this host and client.  #  $clientsamedom    - LonCAPA domain same for this host and client.
 #  $clientintdom   - LonCAPA "internet domain" for client.  #  $clientintdom     - LonCAPA "internet domain" for client.
 #  $clientsameinst - LonCAPA "internet domain" same for this host & client.  #  $clientsameinst   - LonCAPA "internet domain" same for this host & client.
   #  $clientremoteok   - If current domain permits hosting on this client: 1
   #  %clientprohibited - Commands prohibited for domain's users for this client.
   #
   #  if the host and client have the same "internet domain", then the value
   #  of $clientremoteok is not used, and no commands are prohibited.
 #  #
 #  returns 1 to indicate package variables have been set for current client.  #  returns 1 to indicate package variables have been set for current client.
 #  #
Line 7582  sub set_client_info { Line 8053  sub set_client_info {
     my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);      my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
     my $homedom = &Apache::lonnet::host_domain($clientserverhomeID);      my $homedom = &Apache::lonnet::host_domain($clientserverhomeID);
     my $samedom = 0;      my $samedom = 0;
     if ($perlvar{'lonDefDom'} eq $homedom) {      if ($perlvar{'lonDefDomain'} eq $homedom) {
         $samedom = 1;          $samedom = 1;
     }      }
     my $intdom = &Apache::lonnet::internet_dom($clientserverhomeID);      my $intdom = &Apache::lonnet::internet_dom($clientserverhomeID);
Line 7602  sub set_client_info { Line 8073  sub set_client_info {
         $clientsamedom = $samedom;          $clientsamedom = $samedom;
         $clientintdom = $intdom;          $clientintdom = $intdom;
         $clientsameinst = $sameinst;          $clientsameinst = $sameinst;
           if ($clientsameinst) {
               undef($clientremoteok);
               undef(%clientprohibited);
           } else {
               $clientremoteok = &get_remote_hostable($currentdomainid);
               %clientprohibited = &get_prohibited($currentdomainid);
           }
         return 1;          return 1;
     }      }
 }  }
Line 8317  sub make_passwd_file { Line 8795  sub make_passwd_file {
  $result = "pass_file_failed_error";   $result = "pass_file_failed_error";
     }      }
  }   }
       } elsif ($umode eq 'lti') {
           my $pf = IO::File->new(">$passfilename");
           if($pf) {
               print $pf "lti:\n";
               &update_passwd_history($uname,$udom,$umode,$action);
           } else {
               $result = "pass_file_failed_error";
           }
     } else {      } else {
  $result="auth_mode_error";   $result="auth_mode_error";
     }      }
Line 8341  sub sethost { Line 8827  sub sethost {
  eq &Apache::lonnet::get_host_ip($hostid)) {   eq &Apache::lonnet::get_host_ip($hostid)) {
  $currenthostid  =$hostid;   $currenthostid  =$hostid;
  $currentdomainid=&Apache::lonnet::host_domain($hostid);   $currentdomainid=&Apache::lonnet::host_domain($hostid);
           &set_client_info();
 # &logthis("Setting hostid to $hostid, and domain to $currentdomainid");  # &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
     } else {      } else {
  &logthis("Requested host id $hostid not an alias of ".   &logthis("Requested host id $hostid not an alias of ".
Line 8417  sub get_prohibited { Line 8904  sub get_prohibited {
     return %prohibited;      return %prohibited;
 }  }
   
   sub get_remote_hostable {
       my ($dom) = @_;
       my $result;
       if ($clientintdom) {
           $result = 1;
           my $remsessconf = &get_usersession_config($dom,'remotesession');
           if (ref($remsessconf) eq 'HASH') {
               if (ref($remsessconf->{'remote'}) eq 'HASH') {
                   if (ref($remsessconf->{'remote'}->{'excludedomain'}) eq 'ARRAY') {
                       if (grep(/^\Q$clientintdom\E$/,@{$remsessconf->{'remote'}->{'excludedomain'}})) {
                           $result = 0;
                       }
                   }
                   if (ref($remsessconf->{'remote'}->{'includedomain'}) eq 'ARRAY') {
                       if (grep(/^\Q$clientintdom\E$/,@{$remsessconf->{'remote'}->{'includedomain'}})) {
                           $result = 1;
                       } else {
                           $result = 0;
                       }
                   }
               }
           }
       }
       return $result;
   }
   
 sub distro_and_arch {  sub distro_and_arch {
     return $dist.':'.$arch;      return $dist.':'.$arch;
 }  }
Line 8742  IO::File Line 9255  IO::File
 Apache::File  Apache::File
 POSIX  POSIX
 Crypt::IDEA  Crypt::IDEA
 LWP::UserAgent()  
 GDBM_File  GDBM_File
 Authen::Krb4  Authen::Krb4
 Authen::Krb5  Authen::Krb5
Line 8824  is closed and the child exits. Line 9336  is closed and the child exits.
 =item Red CRITICAL Can't get key file <error>          =item Red CRITICAL Can't get key file <error>        
   
 SSL key negotiation is being attempted but the call to  SSL key negotiation is being attempted but the call to
 lonssl::KeyFile  failed.  This usually means that the  lonssl::KeyFile failed.  This usually means that the
 configuration file is not correctly defining or protecting  configuration file is not correctly defining or protecting
 the directories/files lonCertificateDirectory or  the directories/files lonCertificateDirectory or
 lonnetPrivateKey  lonnetPrivateKey
Removed from v.1.536  
changed lines
  Added in v.1.570

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