Return to loncgi.pm CVS log

Up to [LON-CAPA] / loncom / cgi

- Use 'secure' attribute for session cookie on servers using Apache/SSL.

    1: #
    2: # LON-CAPA helpers for cgi-bin scripts
    3: #
    4: # $Id: loncgi.pm,v 1.16 2018/07/04 16:58:26 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, and retrieving arguments passed in via a CGI's Query String.
   41: 
   42: =head1 Subroutines
   43: 
   44: =over 4 
   45: 
   46: =cut
   47: 
   48: #############################################
   49: #############################################
   50: package LONCAPA::loncgi;
   51: 
   52: use strict;
   53: use warnings FATAL=>'all';
   54: no warnings 'uninitialized';
   55: 
   56: use lib '/home/httpd/lib/perl/';
   57: use CGI qw(:standard);
   58: use CGI::Cookie();
   59: use MIME::Types();
   60: use Fcntl qw(:flock);
   61: use LONCAPA;
   62: use LONCAPA::Configuration();
   63: use GDBM_File;
   64: use Apache::lonlocal;
   65: 
   66: my $lonidsdir;
   67: 
   68: BEGIN {
   69:     my $perlvar=LONCAPA::Configuration::read_conf('loncapa.conf');
   70:     delete $perlvar->{'lonReceipt'};
   71:     $lonidsdir = $perlvar->{'lonIDsDir'};
   72: }
   73: 
   74: 
   75: #############################################
   76: #############################################
   77: 
   78: =pod
   79: 
   80: =item check_cookie_and_load_env()
   81: 
   82: Inputs: 1 ( optional). When called from a handler in mod_perl,
   83:         pass in the request object.
   84: 
   85: Returns: 1 if the user has a LON-CAPA cookie, 0 if not.
   86: Side effect: Loads the user's environment into the %env hash
   87:              if the cookie is correct.
   88: 
   89: =cut
   90: 
   91: #############################################
   92: #############################################
   93: sub check_cookie_and_load_env {
   94:     my ($r) = @_;
   95:     my ($hascookie,$handle) = &check_cookie($r);
   96:     if (($hascookie) && ($handle)) {
   97:         &transfer_profile_to_env($handle);
   98:     }
   99:     return $hascookie;
  100: }
  101: 
  102: #############################################
  103: #############################################
  104: 
  105: =pod
  106: 
  107: =item check_cookie()
  108: 
  109: Inputs: none
  110: 
  111: Array context:
  112: Returns: (1,$handle) if the user has a LON-CAPA cookie;
  113: (0) if user does not have a LON-CAPA cookie.
  114: 
  115: Scalar context:
  116: Returns: 1 if the user has a LON-CAPA cookie and 0 if not.
  117: 
  118: =cut
  119: 
  120: #############################################
  121: #############################################
  122: sub check_cookie {
  123:     my ($r) = @_;
  124:     my %cookies;
  125:     if (ref($r)) {
  126:         %cookies = CGI::Cookie->fetch($r);
  127:     } else {
  128:         %cookies = CGI::Cookie->fetch();
  129:     }
  130:     if (keys(%cookies)) {
  131:         my $name = 'lonID';
  132:         my $secure = 'lonSID';
  133:         my $linkname = 'lonLinkID';
  134:         my $pubname = 'lonPubID';
  135:         my $lonid;
  136:         if (exists($cookies{$secure})) {
  137:             $lonid=$cookies{$secure};
  138:         } elsif (exists($cookies{$name})) {
  139:             $lonid=$cookies{$name};
  140:         } elsif (exists($cookies{$linkname})) {
  141:             $lonid=$cookies{$linkname};
  142:         } elsif (exists($cookies{$pubname})) {
  143:             $lonid=$cookies{$pubname};
  144:         }
  145:         if ($lonid) {
  146:             my $handle=&LONCAPA::clean_handle($lonid->value);
  147:             if ($handle) {
  148:                 if (-l "$lonidsdir/$handle.id") {
  149:                     my $link = readlink("$lonidsdir/$handle.id");
  150:                     if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
  151:                         $handle = $1;
  152:                     }
  153:                 }
  154:                 if (-e "$lonidsdir/".$handle.".id") {
  155:                     # valid cookie found
  156:                     if (wantarray) {
  157:                         return (1,$handle);
  158:                     } else {
  159:                         return 1;
  160:                     }
  161:                 }
  162:             }
  163:         }
  164:     }
  165:     # No valid cookie found
  166:     if (wantarray) {
  167:         return (0);
  168:     } else {
  169:         return 0;
  170:     }
  171: }
  172: 
  173: #############################################
  174: #############################################
  175: 
  176: =pod
  177: 
  178: =item transfer_profile_to_env()
  179: 
  180: Load the users environment into the %env hash.
  181: 
  182: Inputs: $handle, the name of the users LON-CAPA cookie.
  183: 
  184: Returns: undef
  185: 
  186: =cut
  187: 
  188: #############################################
  189: #############################################
  190: sub transfer_profile_to_env {
  191:     my ($handle)=@_;
  192:     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
  193: 	    0640)) {
  194: 	%Apache::lonnet::env = %disk_env;
  195: 	untie(%disk_env);
  196:     }
  197:     $Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
  198:     return undef;
  199: }
  200: 
  201: #############################################
  202: #############################################
  203: 
  204: =pod
  205: 
  206: =item missing_cookie_msg()
  207: 
  208: Inputs: none
  209: Returns: HTML for a page indicating cookie information absent. 
  210: 
  211: =cut
  212: 
  213: #############################################
  214: #############################################
  215: sub missing_cookie_msg {
  216:     my %lt = &Apache::lonlocal::texthash (
  217:                         cook => 'Bad Cookie',
  218:                         your => 'Your cookie information is incorrect.',
  219:              );
  220:     return <<END;
  221: <html>
  222: <head><title>$lt{'cook'}</title></head>
  223: <body>
  224: $lt{'your'}
  225: </body>
  226: </html>
  227: END
  228: 
  229: }
  230: 
  231: #############################################
  232: #############################################
  233: 
  234: =pod
  235: 
  236: =cgi_getitems()
  237: 
  238: Inputs: $query - the CGI query string (required)
  239:         $getitems - reference to a hash (required)
  240:         $possname - permitted names of keys (optional)
  241: 
  242: Returns: nothing
  243: 
  244: Side Effects: populates $getitems hash ref with key => value
  245:               where each key is the name of the form item in the query string
  246:               and value is an array of corresponding values. 
  247: 
  248: =cut
  249: 
  250: #############################################
  251: #############################################
  252: sub cgi_getitems {
  253:     my ($query,$getitems,$possnames)= @_;
  254:     foreach (split(/&/,$query)) {
  255:         my ($name, $value) = split(/=/,$_);
  256:         $name = &unescape($name);
  257:         if (ref($possnames) eq 'ARRAY') {
  258:             next unless (grep(/^\Q$name\E$/,@{$possnames}));
  259:         }
  260:         $value =~ tr/+/ /;
  261:         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  262:         push(@{$$getitems{$name}},$value);
  263:     }
  264:     return;
  265: }
  266: 
  267: #############################################
  268: #############################################
  269: 
  270: =pod
  271: 
  272: =cgi_header()
  273: 
  274: Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
  275:         $nocache     - Boolean 1 = nocache
  276: Returns: HTTP Response headers constructed using CGI.pm
  277: 
  278: =cut
  279: 
  280: #############################################
  281: #############################################
  282: sub cgi_header {
  283:     my ($contenttype,$nocache) = @_;
  284:     my $mimetypes = MIME::Types->new;
  285:     my %headers;
  286:     if ($contenttype ne '') {
  287:         if ($mimetypes->type($contenttype) ne '') {
  288:             $headers{'-type'} = $contenttype;
  289:             if ($contenttype =~ m{^text/}) {
  290:                 $headers{'-charset'} = 'utf-8';
  291:             }
  292:         }
  293:     }
  294:     if ($nocache) {
  295:        $headers{'-expires'} = 'now';
  296:     }
  297:     if (%headers) {
  298:         return CGI::header(%headers);
  299:     }
  300:     return;
  301: }
  302: 
  303: =pod
  304: 
  305: =back
  306: 
  307: =cut
  308: 
  309: 1;
  310: 
  311: __END__