Return to loncgi.pm CVS log

Up to [LON-CAPA] / loncom / cgi

- When calling loncgi::check_cookie_and_load_env() from a handler in mod_perl (i.e., lonstatusacc) pass in the request object as an argument to keep CGI::Cookie happy.

    1: #
    2: # LON-CAPA helpers for cgi-bin scripts
    3: #
    4: # $Id: loncgi.pm,v 1.10 2008/11/30 14:47:18 raeburn Exp $
    5: #
    6: # Copyright Michigan State University Board of Trustees
    7: #
    8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
    9: #
   10: # LON-CAPA is free software; you can redistribute it and/or modify
   11: # it under the terms of the GNU General Public License as published by
   12: # the Free Software Foundation; either version 2 of the License, or
   13: # (at your option) any later version.
   14: #
   15: # LON-CAPA is distributed in the hope that it will be useful,
   16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18: # GNU General Public License for more details.
   19: #
   20: # You should have received a copy of the GNU General Public License
   21: # along with LON-CAPA; if not, write to the Free Software
   22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   23: #
   24: # /home/httpd/html/adm/gpl.txt
   25: #
   26: # http://www.lon-capa.org/
   27: #
   28: #############################################
   29: #############################################
   30: 
   31: =pod
   32: 
   33: =head1 NAME
   34: 
   35: loncgi
   36: 
   37: =head1 SYNOPSIS
   38: 
   39: Provides subroutines for checking a LON-CAPA cookie, loading the user's
   40: environment, retrieving arguments passed in via a CGI's Query String,
   41: checking access controls, providing a user with an explanation
   42: when access is denied, and descriptions of various server status pages 
   43: generated by CGI scripts which use these subroutines for authorization.
   44: 
   45: =head1 Subroutines
   46: 
   47: =over 4 
   48: 
   49: =cut
   50: 
   51: #############################################
   52: #############################################
   53: package LONCAPA::loncgi;
   54: 
   55: use strict;
   56: use warnings FATAL=>'all';
   57: no warnings 'uninitialized';
   58: 
   59: use lib '/home/httpd/lib/perl/';
   60: use CGI();
   61: use CGI::Cookie();
   62: use Fcntl qw(:flock);
   63: use LONCAPA;
   64: use LONCAPA::Configuration();
   65: use GDBM_File;
   66: use Apache::lonlocal;
   67: 
   68: my $lonidsdir;
   69: 
   70: BEGIN {
   71:     my $perlvar=LONCAPA::Configuration::read_conf('loncapa.conf');
   72:     delete $perlvar->{'lonReceipt'};
   73:     $lonidsdir = $perlvar->{'lonIDsDir'};
   74: }
   75: 
   76: 
   77: #############################################
   78: #############################################
   79: 
   80: =pod
   81: 
   82: =item check_cookie_and_load_env()
   83: 
   84: Inputs: 1 ( optional). When called from a handler in mod_perl,
   85:         pass in the request object.
   86: 
   87: Returns: 1 if the user has a LON-CAPA cookie 0 if not.
   88: Loads the users environment into the %env hash if the cookie is correct.
   89: 
   90: =cut
   91: 
   92: #############################################
   93: #############################################
   94: sub check_cookie_and_load_env {
   95:     my ($r) = @_;
   96:     my %cookies;
   97:     if (ref($r)) {
   98:         %cookies = CGI::Cookie->fetch($r);    
   99:     } else {
  100:         %cookies = CGI::Cookie->fetch();
  101:     }
  102:     if (exists($cookies{'lonID'}) && 
  103:         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
  104:         # cookie found
  105:         &transfer_profile_to_env($cookies{'lonID'}->value);
  106:         return 1;
  107:     } else {
  108:         # No cookie found
  109:         return 0;
  110:     }
  111: }
  112: 
  113: #############################################
  114: #############################################
  115: 
  116: =pod
  117: 
  118: =item check_cookie()
  119: 
  120: Inputs: none
  121: 
  122: Returns: 1 if the user has a LON-CAPA cookie and 0 if not.
  123: 
  124: =cut
  125: 
  126: #############################################
  127: #############################################
  128: sub check_cookie {
  129:     my %cookies=fetch CGI::Cookie;
  130:     if (exists($cookies{'lonID'}) && 
  131:         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
  132:         # cookie found
  133:         return 1;
  134:     } else {
  135:         # No cookie found
  136:         return 0;
  137:     }
  138: }
  139: 
  140: #############################################
  141: #############################################
  142: 
  143: =pod
  144: 
  145: =item transfer_profile_to_env()
  146: 
  147: Load the users environment into the %env hash.
  148: 
  149: Inputs: $handle, the name of the users LON-CAPA cookie.
  150: 
  151: Returns: undef
  152: 
  153: =cut
  154: 
  155: #############################################
  156: #############################################
  157: sub transfer_profile_to_env {
  158:     my ($handle)=@_;
  159:    if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
  160: 	    0640)) {
  161: 	%Apache::lonnet::env = %disk_env;
  162: 	untie(%disk_env);
  163:     }
  164:     $Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
  165:     return undef;
  166: }
  167: 
  168: #############################################
  169: #############################################
  170: 
  171: =pod
  172: 
  173: =item check_ipbased_access()
  174: 
  175: Inputs: $page, the identifier of the page to be viewed,
  176:         can be one of the keys in the hash from &serverstatus_titles()
  177: 
  178:         $ip, the IP address of the client requesting the page.
  179: 
  180: Returns: 1 if access is permitted for the requestor's IP.
  181:          Access is allowed if on of the following is true:
  182:          (a) the requestor IP is the loopback address
  183:          (b) Domain configurations for domains hosted on this server include
  184:              the requestor's IP as one of the specified IPs with access
  185:              to this page. (does not apply to 'ping' page type) 
  186: =cut
  187: 
  188: #############################################
  189: #############################################
  190: sub check_ipbased_access {
  191:     my ($page,$ip) = @_;
  192:     my $allowed;
  193:     if (!defined($ip)) {
  194:         $ip = $ENV{'REMOTE_ADDR'};
  195:     }
  196:     if (($page ne 'lonstatus') && ($page ne 'serverstatus')) {
  197:         if ($ip eq '127.0.0.1') {
  198:             $allowed = 1;
  199:             return $allowed;
  200:         }
  201:     }
  202:     if ($page ne 'ping') {
  203:         my @poss_domains = &Apache::lonnet::current_machine_domains();
  204:         foreach my $dom (@poss_domains) {
  205:             my %domconfig = &Apache::lonnet::get_dom('configuration',['serverstatuses'],$dom);
  206:             if (ref($domconfig{'serverstatuses'}) eq 'HASH') {
  207:                 if (ref($domconfig{'serverstatuses'}{$page}) eq 'HASH') {
  208:                     if ($domconfig{'serverstatuses'}{$page}{'machines'} ne '') {
  209:                         my @okmachines = split(/,/,$domconfig{'serverstatuses'}{$page}{'machines'});
  210:                         if (grep(/^\Q$ip\E$/,@okmachines)) {
  211:                             $allowed = 1;
  212:                             last;
  213:                         }
  214:                     }
  215:                 }
  216:             }
  217:         }
  218:     }
  219:     return $allowed;
  220: }
  221: 
  222: #############################################
  223: #############################################
  224: 
  225: =pod
  226: 
  227: =item can_view()
  228: 
  229: Inputs: $page, the identifier of the page to be viewed,
  230:         can be one of the keys in the hash from &serverstatus_titles()
  231: 
  232: Returns: 1 if access to the page is permitted.
  233:          Access allowed if one of the following is true:
  234:          (a) Requestor has LON-CAPA superuser role
  235:          (b) Requestor's role is Domain Coordinator in one of the domains
  236:              hosted on this server
  237:          (c) Domain configurations for domains hosted on this server include
  238:              the requestor as one of the named users (username:domain) with access
  239:              to the page.
  240: 
  241:          In the case of requests for the 'ping' page, and access is also allowed if 
  242:          at least one domain hosted on requestor's server is also hosted on this server.
  243: 
  244: =cut
  245: 
  246: #############################################
  247: #############################################
  248: sub can_view {
  249:     my ($page) = @_;
  250:     my $allowed;
  251:     if ($Apache::lonnet::env{'request.role'} =~ m{^su\./}) {
  252:         $allowed = 1;
  253:     } elsif ($page eq 'ping') {
  254:         my @poss_domains = &Apache::lonnet::current_machine_domains();
  255:         my @hostids= &Apache::lonnet::get_hosts_from_ip($ENV{'REMOTE_ADDR'});
  256:         foreach my $hostid (@hostids) { 
  257:             my $hostdom = &Apache::lonnet::host_domain($hostid);
  258:             if (grep(/^\Q$hostdom\E$/,@poss_domains)) {
  259:                 $allowed = 1;
  260:                 last;
  261:             }
  262:         }
  263:     } else {
  264:         my @poss_domains = &Apache::lonnet::current_machine_domains();
  265:         foreach my $dom (@poss_domains) {
  266:             my %domconfig = &Apache::lonnet::get_dom('configuration',['serverstatuses'],$dom);
  267:             if ($Apache::lonnet::env{'request.role'} eq "dc./$dom/") {
  268:                 $allowed = 1;
  269:             } elsif (ref($domconfig{'serverstatuses'}) eq 'HASH') {
  270:                 if (ref($domconfig{'serverstatuses'}{$page}) eq 'HASH') {
  271:                     if ($domconfig{'serverstatuses'}{$page}{'namedusers'} ne '') {
  272:                         my @okusers = split(/,/,$domconfig{'serverstatuses'}{$page}{'namedusers'});
  273:                         if (grep(/^\Q$Apache::lonnet::env{'user.name'}:$Apache::lonnet::env{'user.domain'}\E$/,@okusers)) {
  274:                             $allowed = 1;
  275:                         }
  276:                     }
  277:                 }
  278:             }
  279:             last if $allowed;
  280:         }
  281:     }
  282:     return $allowed;
  283: }
  284: 
  285: #############################################
  286: #############################################
  287: 
  288: =pod
  289: 
  290: =unauthorized_msg()
  291: 
  292: Inputs: $page, the identifier of the page to be viewed,
  293:         can be one of the keys in the hash from &serverstatus_titles()
  294: 
  295: Returns: A string explaining why access was denied for the particular page.
  296: 
  297: =cut
  298: 
  299: #############################################
  300: #############################################
  301: sub unauthorized_msg {
  302:     my ($page) = @_;
  303:     my $titles = &serverstatus_titles();
  304:     if ($page eq 'clusterstatus') {
  305:         return &mt('Your current role does not permit you to view the requested server status page: [_1]',$titles->{$page});
  306:     }
  307:     my @poss_domains = &Apache::lonnet::current_machine_domains();
  308:     if (@poss_domains == 1) {
  309:         my $domdesc = &Apache::lonnet::domain($poss_domains[0]);
  310:         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});
  311:     } elsif (@poss_domains > 1) {
  312:         my $output = &mt('Configurations for the domains housed on this server: ').'<ul>';
  313:         foreach my $dom (@poss_domains) {
  314:             my $domdesc = &Apache::lonnet::domain($dom);
  315:             $output .= '<li>'.&Apache::lonnet::domain($dom).'('.$dom.')</li>';
  316:         }
  317:         $output .= '</ul>'.&mt('do not permit you to view the requested server status page: [_1]',$titles->{$page});
  318:         return $output;
  319:     } else {
  320:         return &mt('No domain information exists for this server');
  321:     }
  322: }
  323: 
  324: #############################################
  325: #############################################
  326: 
  327: =pod
  328: 
  329: =item missing_cookie_msg()
  330: 
  331: Inputs: none
  332: Returns: HTML for a page indicating cookie information absent. 
  333: 
  334: =cut
  335: 
  336: #############################################
  337: #############################################
  338: sub missing_cookie_msg {
  339:     my %lt = &Apache::lonlocal::texthash (
  340:                         cook => 'Bad Cookie',
  341:                         your => 'Your cookie information is incorrect.',
  342:              );
  343:     return <<END;
  344: <html>
  345: <head><title>$lt{'cook'}</title></head>
  346: <body>
  347: $lt{'your'}
  348: </body>
  349: </html>
  350: END
  351: 
  352: }
  353: 
  354: #############################################
  355: #############################################
  356: 
  357: =pod
  358: 
  359: =item serverstatus_titles()
  360: 
  361: Inputs: none
  362: 
  363: Returns: a reference to a hash of pages, where in the hash
  364:          keys are names of pages which employ loncgi.pm
  365:          or lonstatusacc.pm for access control, 
  366:          and corresponding values are descriptions of each page 
  367: 
  368: =cut
  369: 
  370: #############################################
  371: #############################################
  372: sub serverstatus_titles {
  373:     my %titles = &Apache::lonlocal::texthash (
  374:                    'userstatus'        => 'User Status Summary',
  375:                    'lonstatus'         => 'Display Detailed Report',
  376:                    'loncron'           => 'Generate Detailed Report',
  377:                    'server-status'     => 'Apache Status Page',
  378:                    'codeversions'      => 'LON-CAPA Module Versions',
  379:                    'clusterstatus'     => 'Domain status',
  380:                    'metadata_keywords' => 'Display Metadata Keywords',
  381:                    'metadata_harvest'  => 'Harvest Metadata Searches',
  382:                    'takeoffline'       => 'Offline - replace Log-in page',
  383:                    'takeonline'        => 'Online - restore Log-in page',
  384:                    'showenv'           => "Show user environment",
  385:                  );
  386:     return \%titles;
  387: }
  388: 
  389: #############################################
  390: #############################################
  391: 
  392: =pod
  393: 
  394: =cgi_getitems()
  395: 
  396: Inputs: $query (the CGI query string), and $getitems, a reference to a hash 
  397: 
  398: Returns: nothing
  399: 
  400: Side Effects: populates $getitems hash ref with key => value
  401:               where each key is the name of the form item in the query string
  402:               and value is an array of corresponding values. 
  403: =cut
  404: 
  405: #############################################
  406: #############################################
  407: sub cgi_getitems {
  408:     my ($query,$getitems)= @_;
  409:     foreach (split(/&/,$query)) {
  410:         my ($name, $value) = split(/=/,$_);
  411:         $name = &unescape($name);
  412:         $value =~ tr/+/ /;
  413:         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  414:         push(@{$$getitems{$name}},$value);
  415:     }
  416:     return;
  417: }
  418: 
  419: =pod
  420: 
  421: =back
  422: 
  423: =cut
  424: 
  425: 1;
  426: 
  427: __END__