Return to loncacc.pm CVS log

Up to [LON-CAPA] / loncom / auth

pod; remove void map -Scott Harrison

    1: # The LearningOnline Network
    2: # Cookie Based Access Handler for Construction Area
    3: # (lonacc: 5/21/99,5/22,5/29,5/31 Gerd Kortemeyer)
    4: #
    5: # $Id: loncacc.pm,v 1.18 2001/12/21 16:57:54 harris41 Exp $
    6: #
    7: # Copyright Michigan State University Board of Trustees
    8: #
    9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
   10: #
   11: # LON-CAPA is free software; you can redistribute it and/or modify
   12: # it under the terms of the GNU General Public License as published by
   13: # the Free Software Foundation; either version 2 of the License, or
   14: # (at your option) any later version.
   15: #
   16: # LON-CAPA is distributed in the hope that it will be useful,
   17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   19: # GNU General Public License for more details.
   20: #
   21: # You should have received a copy of the GNU General Public License
   22: # along with LON-CAPA; if not, write to the Free Software
   23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   24: #
   25: # /home/httpd/html/adm/gpl.txt
   26: #
   27: # http://www.lon-capa.org/
   28: #
   29: # YEAR=2000
   30: # 6/15,16/11,22/11,
   31: # YEAR=2001
   32: # 01/06,01/11,6/1,9/25,9/28,11/22,12/25,12/26,
   33: # 01/06/01,05/04,05/05,05/09 Gerd Kortemeyer
   34: # 12/21 Scott Harrison
   35: #
   36: ###
   37: 
   38: package Apache::loncacc;
   39: 
   40: use strict;
   41: use Apache::Constants qw(:common :http :methods);
   42: use Apache::File;
   43: use CGI::Cookie();
   44: use Fcntl qw(:flock);
   45: 
   46: sub constructaccess {
   47:     my ($url,$ownerdomain)=@_;
   48:     my ($ownername)=($url=~/\/(?:\~|priv\/|home\/)(\w+)/);
   49:     unless (($ownername) && ($ownerdomain)) { return ''; }
   50: 
   51:     if (($ownername eq $ENV{'user.name'}) &&
   52:         ($ownerdomain eq $ENV{'user.domain'})) {
   53: 	return ($ownername,$ownerdomain);
   54:     }
   55: 
   56:     my $capriv='user.priv.ca./'.
   57:                $ownerdomain.'/'.$ownername.'./'.
   58: 	       $ownerdomain.'/'.$ownername;
   59:     foreach (keys %ENV) {
   60:         if ($_ eq $capriv) {
   61:            return ($ownername,$ownerdomain);
   62:         }
   63:     }
   64: 
   65:     return '';
   66: }
   67: 
   68: sub handler {
   69:     my $r = shift;
   70:     my $requrl=$r->uri;
   71:     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
   72:     my $lonid=$cookies{'lonID'};
   73:     my $cookie;
   74:     if ($lonid) {
   75: 	my $handle=$lonid->value;
   76:         $handle=~s/\W//g;
   77:         my $lonidsdir=$r->dir_config('lonIDsDir');
   78:         if ((-e "$lonidsdir/$handle.id") && ($handle ne '')) {
   79:             my @profile;
   80: 	    {
   81:              my $idf=Apache::File->new("$lonidsdir/$handle.id");
   82:              flock($idf,LOCK_SH);
   83:              @profile=<$idf>;
   84:              $idf->close();
   85: 	    }
   86:             my $envi;
   87:             for ($envi=0;$envi<=$#profile;$envi++) {
   88: 		chomp($profile[$envi]);
   89: 		my ($envname,$envvalue)=split(/=/,$profile[$envi]);
   90:                 $ENV{$envname} = $envvalue;
   91:             }
   92:             $ENV{'user.environment'} = "$lonidsdir/$handle.id";
   93:             $ENV{'request.state'}    = "construct";
   94:             $ENV{'request.filename'} = $r->filename;
   95: 
   96:             unless (&constructaccess($requrl,$r->dir_config('lonDefDomain'))) {
   97:                 $r->log_reason("Unauthorized $requrl", $r->filename); 
   98: 	        return HTTP_NOT_ACCEPTABLE;
   99:             }
  100: 
  101: # -------------------------------------------------------- Load POST parameters
  102: 
  103: 
  104:         my $buffer;
  105: 
  106:         $r->read($buffer,$r->header_in('Content-length'));
  107: 
  108: 	unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
  109:             my @pairs=split(/&/,$buffer);
  110:             my $pair;
  111:             foreach $pair (@pairs) {
  112:                my ($name,$value) = split(/=/,$pair);
  113:                $value =~ tr/+/ /;
  114:                $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  115:                $name  =~ tr/+/ /;
  116:                $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  117:                $ENV{"form.$name"}=$value;
  118:             } 
  119:         } else {
  120: 	    my $contentsep=$1;
  121:             my @lines = split (/\n/,$buffer);
  122:             my $name='';
  123:             my $value='';
  124:             my $fname='';
  125:             my $fmime='';
  126:             my $i;
  127:             for ($i=0;$i<=$#lines;$i++) {
  128: 		if ($lines[$i]=~/^$contentsep/) {
  129: 		    if ($name) {
  130:                         chomp($value);
  131: 			if ($fname) {
  132: 			    $ENV{"form.$name.filename"}=$fname;
  133:                             $ENV{"form.$name.mimetype"}=$fmime;
  134:                         } else {
  135:                             $value=~s/\s+$//s;
  136:                         }
  137:                         $ENV{"form.$name"}=$value;
  138:                     }
  139:                     if ($i<$#lines) {
  140: 			$i++;
  141:                         $lines[$i]=~
  142: 		 /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;
  143:                         $name=$1;
  144:                         $value='';
  145:                         if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {
  146: 			   $fname=$1;
  147:                            if 
  148:                             ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {
  149: 			      $fmime=$1;
  150:                               $i++;
  151: 			   } else {
  152:                               $fmime='';
  153:                            }
  154:                         } else {
  155: 			    $fname='';
  156:                             $fmime='';
  157:                         }
  158:                         $i++;
  159:                     }
  160:                 } else {
  161: 		    $value.=$lines[$i]."\n";
  162:                 }
  163:             }
  164: 	}
  165:             $r->method_number(M_GET);
  166: 	    $r->method('GET');
  167:             $r->headers_in->unset('Content-length');
  168: 
  169:             return OK; 
  170:         } else { 
  171:             $r->log_reason("Cookie $handle not valid", $r->filename) 
  172:         };
  173:     }
  174: 
  175: # ----------------------------------------------- Store where they wanted to go
  176: 
  177:     $ENV{'request.firsturl'}=$requrl;
  178:     return FORBIDDEN;
  179: }
  180: 
  181: 1;
  182: __END__
  183: 
  184: =head1 NAME
  185: 
  186: Apache::lonacc - Cookie Based Access Handler for Construction Area
  187: 
  188: =head1 SYNOPSIS
  189: 
  190: Invoked (for various locations) by /etc/httpd/conf/srm.conf:
  191: 
  192:  PerlAccessHandler       Apache::loncacc
  193: 
  194: =head1 INTRODUCTION
  195: 
  196: This module enables cookie based authentication for construction area
  197: and is used to control access for three (essentially equivalent) URIs.
  198: 
  199:  <LocationMatch "^/priv.*">
  200:  <LocationMatch "^/\~.*">
  201:  <LocationMatch "^/\~.*/$">
  202: 
  203: Whenever the client sends the cookie back to the server, 
  204: if the cookie is missing or invalid, the user is re-challenged
  205: for login information.
  206: 
  207: This is part of the LearningOnline Network with CAPA project
  208: described at http://www.lon-capa.org.
  209: 
  210: =head1 HANDLER SUBROUTINE
  211: 
  212: This routine is called by Apache and mod_perl.
  213: 
  214: =over 4
  215: 
  216: =item *
  217: 
  218: load POST parameters
  219: 
  220: =item *
  221: 
  222: store where they wanted to go (first url entered)
  223: 
  224: =back
  225: 
  226: =head1 OTHERSUBROUTINES
  227: 
  228: =over 4
  229: 
  230: =item *
  231: 
  232: constructaccess($url,$ownerdomain) : See if the owner domain and name
  233: in the URL match those in the expected environment.  If so, return 
  234: two element list ($ownername,$ownerdomain).  Else, return null string.
  235: 
  236: =back
  237: 
  238: =cut
  239: 
  240: 
  241: 
  242: 
  243: 
  244: 
  245: