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

Diff for /loncom/cgi/loncgi.pm between versions 1.9 and 1.15

version 1.9, 2008/11/28 20:39:43 version 1.15, 2016/08/01 15:19:05
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 81  BEGIN { Line 79  BEGIN {
   
 =item check_cookie_and_load_env()  =item check_cookie_and_load_env()
   
 Inputs: none  Inputs: 1 ( optional). When called from a handler in mod_perl,
           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.  Loads the users environment into the %env hash if the cookie is correct.
Line 91  Loads the users environment into the %en Line 90  Loads the users environment into the %en
 #############################################  #############################################
 #############################################  #############################################
 sub check_cookie_and_load_env {  sub check_cookie_and_load_env {
     my %cookies=fetch CGI::Cookie;      my ($r) = @_;
       my %cookies;
       if (ref($r)) {
           %cookies = CGI::Cookie->fetch($r);    
       } else {
           %cookies = CGI::Cookie->fetch();
       }
     if (exists($cookies{'lonID'}) &&       if (exists($cookies{'lonID'}) && 
         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {          -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
         # cookie found          # cookie found
Line 149  Returns: undef Line 154  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 163  sub transfer_profile_to_env { Line 168  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 349  END Line 198  END
   
 =pod  =pod
   
 =item serverstatus_titles()  =cgi_getitems()
   
   Inputs: $query - the CGI query string (required)
           $getitems - reference to a hash (required)
           $possname - permitted names of keys (optional)
   
 Inputs: none  Returns: nothing
   
 Returns: a reference to a hash of pages, where in the hash  Side Effects: populates $getitems hash ref with key => value
          keys are names of pages which employ loncgi.pm                where each key is the name of the form item in the query string
          or lonstatusacc.pm for access control,                 and value is an array of corresponding values. 
          and corresponding values are descriptions of each page   
   
 =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 384  sub serverstatus_titles { Line 234  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.9  
changed lines
  Added in v.1.15

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