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

Diff for /loncom/cgi/loncgi.pm between versions 1.10 and 1.16

version 1.10, 2008/11/30 14:47:18 version 1.16, 2018/07/04 16:58:26
Line 37  loncgi Line 37  loncgi
 =head1 SYNOPSIS  =head1 SYNOPSIS
   
 Provides subroutines for checking a LON-CAPA cookie, loading the user's  Provides subroutines for checking a LON-CAPA cookie, loading the user's
 environment, retrieving arguments passed in via a CGI's Query String,  environment, and retrieving arguments passed in via a CGI's Query String.
 checking access controls, providing a user with an explanation  
 when access is denied, and descriptions of various server status pages   
 generated by CGI scripts which use these subroutines for authorization.  
   
 =head1 Subroutines  =head1 Subroutines
   
Line 57  use warnings FATAL=>'all'; Line 54  use warnings FATAL=>'all';
 no warnings 'uninitialized';  no warnings 'uninitialized';
   
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use CGI();  use CGI qw(:standard);
 use CGI::Cookie();  use CGI::Cookie();
   use MIME::Types();
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use LONCAPA;  use LONCAPA;
 use LONCAPA::Configuration();  use LONCAPA::Configuration();
Line 84  BEGIN { Line 82  BEGIN {
 Inputs: 1 ( optional). When called from a handler in mod_perl,  Inputs: 1 ( optional). When called from a handler in mod_perl,
         pass in the request object.          pass in the request object.
   
 Returns: 1 if the user has a LON-CAPA cookie 0 if not.  Returns: 1 if the user has a LON-CAPA cookie, 0 if not.
 Loads the users environment into the %env hash if the cookie is correct.  Side effect: Loads the user's environment into the %env hash
                if the cookie is correct.
   
 =cut  =cut
   
Line 93  Loads the users environment into the %en Line 92  Loads the users environment into the %en
 #############################################  #############################################
 sub check_cookie_and_load_env {  sub check_cookie_and_load_env {
     my ($r) = @_;      my ($r) = @_;
     my %cookies;      my ($hascookie,$handle) = &check_cookie($r);
     if (ref($r)) {      if (($hascookie) && ($handle)) {
         %cookies = CGI::Cookie->fetch($r);              &transfer_profile_to_env($handle);
     } else {  
         %cookies = CGI::Cookie->fetch();  
     }  
     if (exists($cookies{'lonID'}) &&   
         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {  
         # cookie found  
         &transfer_profile_to_env($cookies{'lonID'}->value);  
         return 1;  
     } else {  
         # No cookie found  
         return 0;  
     }      }
       return $hascookie;
 }  }
   
 #############################################  #############################################
Line 119  sub check_cookie_and_load_env { Line 108  sub check_cookie_and_load_env {
   
 Inputs: none  Inputs: none
   
   Array context:
   Returns: (1,$handle) if the user has a LON-CAPA cookie;
   (0) if user does not have a LON-CAPA cookie.
   
   Scalar context:
 Returns: 1 if the user has a LON-CAPA cookie and 0 if not.  Returns: 1 if the user has a LON-CAPA cookie and 0 if not.
   
 =cut  =cut
Line 126  Returns: 1 if the user has a LON-CAPA co Line 120  Returns: 1 if the user has a LON-CAPA co
 #############################################  #############################################
 #############################################  #############################################
 sub check_cookie {  sub check_cookie {
     my %cookies=fetch CGI::Cookie;      my ($r) = @_;
     if (exists($cookies{'lonID'}) &&       my %cookies;
         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {      if (ref($r)) {
         # cookie found          %cookies = CGI::Cookie->fetch($r);
         return 1;      } else {
           %cookies = CGI::Cookie->fetch();
       }
       if (keys(%cookies)) {
           my $name = 'lonID';
           my $secure = 'lonSID';
           my $linkname = 'lonLinkID';
           my $pubname = 'lonPubID';
           my $lonid;
           if (exists($cookies{$secure})) {
               $lonid=$cookies{$secure};
           } elsif (exists($cookies{$name})) {
               $lonid=$cookies{$name};
           } elsif (exists($cookies{$linkname})) {
               $lonid=$cookies{$linkname};
           } elsif (exists($cookies{$pubname})) {
               $lonid=$cookies{$pubname};
           }
           if ($lonid) {
               my $handle=&LONCAPA::clean_handle($lonid->value);
               if ($handle) {
                   if (-l "$lonidsdir/$handle.id") {
                       my $link = readlink("$lonidsdir/$handle.id");
                       if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
                           $handle = $1;
                       }
                   }
                   if (-e "$lonidsdir/".$handle.".id") {
                       # valid cookie found
                       if (wantarray) {
                           return (1,$handle);
                       } else {
                           return 1;
                       }
                   }
               }
           }
       }
       # No valid cookie found
       if (wantarray) {
           return (0);
     } else {      } else {
         # No cookie found  
         return 0;          return 0;
     }      }
 }  }
Line 156  Returns: undef Line 189  Returns: undef
 #############################################  #############################################
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
     my ($handle)=@_;      my ($handle)=@_;
    if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),      if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
     0640)) {      0640)) {
  %Apache::lonnet::env = %disk_env;   %Apache::lonnet::env = %disk_env;
  untie(%disk_env);   untie(%disk_env);
Line 170  sub transfer_profile_to_env { Line 203  sub transfer_profile_to_env {
   
 =pod  =pod
   
 =item check_ipbased_access()  
   
 Inputs: $page, the identifier of the page to be viewed,  
         can be one of the keys in the hash from &serverstatus_titles()  
   
         $ip, the IP address of the client requesting the page.  
   
 Returns: 1 if access is permitted for the requestor's IP.  
          Access is allowed if on of the following is true:  
          (a) the requestor IP is the loopback address  
          (b) Domain configurations for domains hosted on this server include  
              the requestor's IP as one of the specified IPs with access  
              to this page. (does not apply to 'ping' page type)   
 =cut  
   
 #############################################  
 #############################################  
 sub check_ipbased_access {  
     my ($page,$ip) = @_;  
     my $allowed;  
     if (!defined($ip)) {  
         $ip = $ENV{'REMOTE_ADDR'};  
     }  
     if (($page ne 'lonstatus') && ($page ne 'serverstatus')) {  
         if ($ip eq '127.0.0.1') {  
             $allowed = 1;  
             return $allowed;  
         }  
     }  
     if ($page ne 'ping') {  
         my @poss_domains = &Apache::lonnet::current_machine_domains();  
         foreach my $dom (@poss_domains) {  
             my %domconfig = &Apache::lonnet::get_dom('configuration',['serverstatuses'],$dom);  
             if (ref($domconfig{'serverstatuses'}) eq 'HASH') {  
                 if (ref($domconfig{'serverstatuses'}{$page}) eq 'HASH') {  
                     if ($domconfig{'serverstatuses'}{$page}{'machines'} ne '') {  
                         my @okmachines = split(/,/,$domconfig{'serverstatuses'}{$page}{'machines'});  
                         if (grep(/^\Q$ip\E$/,@okmachines)) {  
                             $allowed = 1;  
                             last;  
                         }  
                     }  
                 }  
             }  
         }  
     }  
     return $allowed;  
 }  
   
 #############################################  
 #############################################  
   
 =pod  
   
 =item can_view()  
   
 Inputs: $page, the identifier of the page to be viewed,  
         can be one of the keys in the hash from &serverstatus_titles()  
   
 Returns: 1 if access to the page is permitted.  
          Access allowed if one of the following is true:  
          (a) Requestor has LON-CAPA superuser role  
          (b) Requestor's role is Domain Coordinator in one of the domains  
              hosted on this server  
          (c) Domain configurations for domains hosted on this server include  
              the requestor as one of the named users (username:domain) with access  
              to the page.  
   
          In the case of requests for the 'ping' page, and access is also allowed if   
          at least one domain hosted on requestor's server is also hosted on this server.  
   
 =cut  
   
 #############################################  
 #############################################  
 sub can_view {  
     my ($page) = @_;  
     my $allowed;  
     if ($Apache::lonnet::env{'request.role'} =~ m{^su\./}) {  
         $allowed = 1;  
     } elsif ($page eq 'ping') {  
         my @poss_domains = &Apache::lonnet::current_machine_domains();  
         my @hostids= &Apache::lonnet::get_hosts_from_ip($ENV{'REMOTE_ADDR'});  
         foreach my $hostid (@hostids) {   
             my $hostdom = &Apache::lonnet::host_domain($hostid);  
             if (grep(/^\Q$hostdom\E$/,@poss_domains)) {  
                 $allowed = 1;  
                 last;  
             }  
         }  
     } else {  
         my @poss_domains = &Apache::lonnet::current_machine_domains();  
         foreach my $dom (@poss_domains) {  
             my %domconfig = &Apache::lonnet::get_dom('configuration',['serverstatuses'],$dom);  
             if ($Apache::lonnet::env{'request.role'} eq "dc./$dom/") {  
                 $allowed = 1;  
             } elsif (ref($domconfig{'serverstatuses'}) eq 'HASH') {  
                 if (ref($domconfig{'serverstatuses'}{$page}) eq 'HASH') {  
                     if ($domconfig{'serverstatuses'}{$page}{'namedusers'} ne '') {  
                         my @okusers = split(/,/,$domconfig{'serverstatuses'}{$page}{'namedusers'});  
                         if (grep(/^\Q$Apache::lonnet::env{'user.name'}:$Apache::lonnet::env{'user.domain'}\E$/,@okusers)) {  
                             $allowed = 1;  
                         }  
                     }  
                 }  
             }  
             last if $allowed;  
         }  
     }  
     return $allowed;  
 }  
   
 #############################################  
 #############################################  
   
 =pod  
   
 =unauthorized_msg()  
   
 Inputs: $page, the identifier of the page to be viewed,  
         can be one of the keys in the hash from &serverstatus_titles()  
   
 Returns: A string explaining why access was denied for the particular page.  
   
 =cut  
   
 #############################################  
 #############################################  
 sub unauthorized_msg {  
     my ($page) = @_;  
     my $titles = &serverstatus_titles();  
     if ($page eq 'clusterstatus') {  
         return &mt('Your current role does not permit you to view the requested server status page: [_1]',$titles->{$page});  
     }  
     my @poss_domains = &Apache::lonnet::current_machine_domains();  
     if (@poss_domains == 1) {  
         my $domdesc = &Apache::lonnet::domain($poss_domains[0]);  
         return &mt('The configuration for domain: [_1] does not permit you to view the requested server status page: [_2].',"$domdesc ($poss_domains[0])",$titles->{$page});  
     } elsif (@poss_domains > 1) {  
         my $output = &mt('Configurations for the domains housed on this server: ').'<ul>';  
         foreach my $dom (@poss_domains) {  
             my $domdesc = &Apache::lonnet::domain($dom);  
             $output .= '<li>'.&Apache::lonnet::domain($dom).'('.$dom.')</li>';  
         }  
         $output .= '</ul>'.&mt('do not permit you to view the requested server status page: [_1]',$titles->{$page});  
         return $output;  
     } else {  
         return &mt('No domain information exists for this server');  
     }  
 }  
   
 #############################################  
 #############################################  
   
 =pod  
   
 =item missing_cookie_msg()  =item missing_cookie_msg()
   
 Inputs: none  Inputs: none
Line 356  END Line 233  END
   
 =pod  =pod
   
 =item serverstatus_titles()  =cgi_getitems()
   
 Inputs: none  Inputs: $query - the CGI query string (required)
           $getitems - reference to a hash (required)
           $possname - permitted names of keys (optional)
   
 Returns: a reference to a hash of pages, where in the hash  Returns: nothing
          keys are names of pages which employ loncgi.pm  
          or lonstatusacc.pm for access control,   Side Effects: populates $getitems hash ref with key => value
          and corresponding values are descriptions of each page                 where each key is the name of the form item in the query string
                 and value is an array of corresponding values. 
   
 =cut  =cut
   
 #############################################  #############################################
 #############################################  #############################################
 sub serverstatus_titles {  sub cgi_getitems {
     my %titles = &Apache::lonlocal::texthash (      my ($query,$getitems,$possnames)= @_;
                    'userstatus'        => 'User Status Summary',      foreach (split(/&/,$query)) {
                    'lonstatus'         => 'Display Detailed Report',          my ($name, $value) = split(/=/,$_);
                    'loncron'           => 'Generate Detailed Report',          $name = &unescape($name);
                    'server-status'     => 'Apache Status Page',          if (ref($possnames) eq 'ARRAY') {
                    'codeversions'      => 'LON-CAPA Module Versions',              next unless (grep(/^\Q$name\E$/,@{$possnames}));
                    'clusterstatus'     => 'Domain status',          }
                    'metadata_keywords' => 'Display Metadata Keywords',          $value =~ tr/+/ /;
                    'metadata_harvest'  => 'Harvest Metadata Searches',          $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    'takeoffline'       => 'Offline - replace Log-in page',          push(@{$$getitems{$name}},$value);
                    'takeonline'        => 'Online - restore Log-in page',      }
                    'showenv'           => "Show user environment",      return;
                  );  
     return \%titles;  
 }  }
   
 #############################################  #############################################
Line 391  sub serverstatus_titles { Line 269  sub serverstatus_titles {
   
 =pod  =pod
   
 =cgi_getitems()  =cgi_header()
   
 Inputs: $query (the CGI query string), and $getitems, a reference to a hash   
   
 Returns: nothing  Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
           $nocache     - Boolean 1 = nocache
   Returns: HTTP Response headers constructed using CGI.pm
   
 Side Effects: populates $getitems hash ref with key => value  
               where each key is the name of the form item in the query string  
               and value is an array of corresponding values.   
 =cut  =cut
   
 #############################################  #############################################
 #############################################  #############################################
 sub cgi_getitems {  sub cgi_header {
     my ($query,$getitems)= @_;      my ($contenttype,$nocache) = @_;
     foreach (split(/&/,$query)) {      my $mimetypes = MIME::Types->new;
         my ($name, $value) = split(/=/,$_);      my %headers;
         $name = &unescape($name);      if ($contenttype ne '') {
         $value =~ tr/+/ /;          if ($mimetypes->type($contenttype) ne '') {
         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;              $headers{'-type'} = $contenttype;
         push(@{$$getitems{$name}},$value);              if ($contenttype =~ m{^text/}) {
                   $headers{'-charset'} = 'utf-8';
               }
           }
       }
       if ($nocache) {
          $headers{'-expires'} = 'now';
       }
       if (%headers) {
           return CGI::header(%headers);
     }      }
     return;      return;
 }  }
Removed from v.1.10  
changed lines
  Added in v.1.16

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