loncom/cgi/loncgi.pm - diff

Return to loncgi.pm CVS log

Up to [LON-CAPA] / loncom / cgi

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

-version 1.8, 2006/09/19 21:36:31
+version 1.10, 2008/11/30 14:47:18
  Line 36  loncgi
  =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
- Line 60  use Fcntl qw(:flock);
+ Line 63  use Fcntl qw(:flock);
  use LONCAPA;
  use LONCAPA::Configuration();
  use GDBM_File;
+ use Apache::lonlocal;
  my $lonidsdir;
- Line 69  BEGIN {
+ Line 73  BEGIN {
      $lonidsdir = $perlvar->{'lonIDsDir'};
  }
  #############################################
  #############################################
  =pod
- =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.
  Loads the users environment into the %env hash if the cookie is correct.
- Line 86  Loads the users environment into the %en
+ Line 92  Loads the users environment into the %en
  #############################################
  #############################################
  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'}) &&
          -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
          # cookie found
- Line 103  sub check_cookie_and_load_env {
+ Line 115  sub check_cookie_and_load_env {
  =pod
- =item check_cookie
+ =item check_cookie()
  Inputs: none
- Line 130  sub check_cookie {
+ Line 142  sub check_cookie {
  =pod
- =item transfer_profile_to_env
+ =item transfer_profile_to_env()
  Load the users environment into the %env hash.
- Line 156  sub transfer_profile_to_env {
+ Line 168  sub transfer_profile_to_env {
  #############################################
  #############################################
+ =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

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

Removed from v.1.8
changed lines
	Added in v.1.10