[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.13

version 1.10, 2008/11/30 14:47:18 version 1.13, 2013/05/13 01:26:54
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 156  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 170  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 356  END Line 198  END
   
 =pod  =pod
   
 =item serverstatus_titles()  
   
 Inputs: none  
   
 Returns: a reference to a hash of pages, where in the hash  
          keys are names of pages which employ loncgi.pm  
          or lonstatusacc.pm for access control,   
          and corresponding values are descriptions of each page   
   
 =cut  
   
 #############################################  
 #############################################  
 sub serverstatus_titles {  
     my %titles = &Apache::lonlocal::texthash (  
                    'userstatus'        => 'User Status Summary',  
                    'lonstatus'         => 'Display Detailed Report',  
                    'loncron'           => 'Generate Detailed Report',  
                    'server-status'     => 'Apache Status Page',  
                    'codeversions'      => 'LON-CAPA Module Versions',  
                    'clusterstatus'     => 'Domain status',  
                    'metadata_keywords' => 'Display Metadata Keywords',  
                    'metadata_harvest'  => 'Harvest Metadata Searches',  
                    'takeoffline'       => 'Offline - replace Log-in page',  
                    'takeonline'        => 'Online - restore Log-in page',  
                    'showenv'           => "Show user environment",  
                  );  
     return \%titles;  
 }  
   
 #############################################  
 #############################################  
   
 =pod  
   
 =cgi_getitems()  =cgi_getitems()
   
 Inputs: $query (the CGI query string), and $getitems, a reference to a hash   Inputs: $query (the CGI query string), and $getitems, a reference to a hash 
Line 400  Returns: nothing Line 207  Returns: nothing
 Side Effects: populates $getitems hash ref with key => value  Side Effects: populates $getitems hash ref with key => value
               where each key is the name of the form item in the query string                where each key is the name of the form item in the query string
               and value is an array of corresponding values.                 and value is an array of corresponding values. 
   
 =cut  =cut
   
 #############################################  #############################################
Line 415  sub cgi_getitems { Line 223  sub cgi_getitems {
     }      }
     return;      return;
 }  }
   
   #############################################
   #############################################
   
   =pod
   
   =cgi_header()
   
   Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
           $nocache     - Boolean 1 = nocache
   Returns: HTTP Response headers constructed using CGI.pm
   
   =cut
   
   #############################################
   #############################################
   sub cgi_header {
       my ($contenttype,$nocache) = @_;
       my $mimetypes = MIME::Types->new;
       my %headers;
       if ($contenttype ne '') {
           if ($mimetypes->type($contenttype) ne '') {
               $headers{'-type'} = $contenttype;
           }
       }
       if ($nocache) {
          $headers{'-expires'} = 'now';
       }
       if (%headers) {
           return CGI::header(%headers);
       }
       return;
   }
   
 =pod  =pod
   
Removed from v.1.10  
changed lines
  Added in v.1.13

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