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

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

version 1.1, 2003/10/09 22:04:37 version 1.9, 2008/11/28 20:39:43
Line 36  loncgi Line 36  loncgi
   
 =head1 SYNOPSIS  =head1 SYNOPSIS
   
 Provides subroutines for checking a LON-CAPA cookie and loading the users  Provides subroutines for checking a LON-CAPA cookie, loading the user's
 environment.  environment, 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 52  package LONCAPA::loncgi; Line 55  package LONCAPA::loncgi;
 use strict;  use strict;
 use warnings FATAL=>'all';  use warnings FATAL=>'all';
 no warnings 'uninitialized';  no warnings 'uninitialized';
   
   use lib '/home/httpd/lib/perl/';
 use CGI();  use CGI();
 use CGI::Cookie();  use CGI::Cookie();
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
   use LONCAPA;
 use LONCAPA::Configuration();  use LONCAPA::Configuration();
   use GDBM_File;
   use Apache::lonlocal;
   
 my $lonidsdir;  my $lonidsdir;
   
Line 65  BEGIN { Line 73  BEGIN {
     $lonidsdir = $perlvar->{'lonIDsDir'};      $lonidsdir = $perlvar->{'lonIDsDir'};
 }  }
   
   
 #############################################  #############################################
 #############################################  #############################################
   
 =pod  =pod
   
 =item check_cookie_and_load_env  =item check_cookie_and_load_env()
   
 Inputs: none  Inputs: none
   
 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.
   
 =cut  =cut
   
Line 99  sub check_cookie_and_load_env { Line 108  sub check_cookie_and_load_env {
   
 =pod  =pod
   
 =item check_cookie  =item check_cookie()
   
 Inputs: none  Inputs: none
   
Line 126  sub check_cookie { Line 135  sub check_cookie {
   
 =pod  =pod
   
 =item transfer_profile_to_env  =item transfer_profile_to_env()
   
 Load the users environment into the %ENV hash.  Load the users environment into the %env hash.
   
 Inputs: $handle, the name of the users LON-CAPA cookie.  Inputs: $handle, the name of the users LON-CAPA cookie.
   
Line 140  Returns: undef Line 149  Returns: undef
 #############################################  #############################################
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
     my ($handle)=@_;      my ($handle)=@_;
     my @profile;     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
     {      0640)) {
         open(IDFILE, "<$lonidsdir/$handle.id");   %Apache::lonnet::env = %disk_env;
         flock(IDFILE,LOCK_SH);   untie(%disk_env);
         @profile=<IDFILE>;  
         close(IDFILE);  
     }  
     foreach my $envrow (@profile) {  
         chomp($envrow);  
         my ($envname,$envvalue)=split(/=/,$envrow);  
         $ENV{$envname} = $envvalue;  
     }      }
     $ENV{'user.environment'} = "$lonidsdir/$handle.id";      $Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
     return undef;      return undef;
 }  }
   
Line 161  sub transfer_profile_to_env { Line 163  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()
   
   Inputs: none
   Returns: HTML for a page indicating cookie information absent. 
   
   =cut
   
   #############################################
   #############################################
   sub missing_cookie_msg {
       my %lt = &Apache::lonlocal::texthash (
                           cook => 'Bad Cookie',
                           your => 'Your cookie information is incorrect.',
                );
       return <<END;
   <html>
   <head><title>$lt{'cook'}</title></head>
   <body>
   $lt{'your'}
   </body>
   </html>
   END
   
   }
   
   #############################################
   #############################################
   
   =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()
   
   Inputs: $query (the CGI query string), and $getitems, a reference to a hash 
   
   Returns: nothing
   
   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
   
   #############################################
   #############################################
   sub cgi_getitems {
       my ($query,$getitems)= @_;
       foreach (split(/&/,$query)) {
           my ($name, $value) = split(/=/,$_);
           $name = &unescape($name);
           $value =~ tr/+/ /;
           $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
           push(@{$$getitems{$name}},$value);
       }
       return;
   }
   
   =pod
   
 =back  =back
   
 =cut  =cut
Removed from v.1.1  
changed lines
  Added in v.1.9

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