Annotation of loncom/cgi/loncgi.pm, revision 1.9
1.1 matthew 1: #
2: # LON-CAPA helpers for cgi-bin scripts
3: #
1.9 ! raeburn 4: # $Id: loncgi.pm,v 1.8 2006/09/19 21:36:31 albertel Exp $
1.1 matthew 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:
1.9 ! raeburn 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.
1.1 matthew 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';
1.2 albertel 58:
1.7 albertel 59: use lib '/home/httpd/lib/perl/';
1.1 matthew 60: use CGI();
61: use CGI::Cookie();
62: use Fcntl qw(:flock);
1.7 albertel 63: use LONCAPA;
1.1 matthew 64: use LONCAPA::Configuration();
1.8 albertel 65: use GDBM_File;
1.9 ! raeburn 66: use Apache::lonlocal;
1.1 matthew 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:
1.9 ! raeburn 76:
1.1 matthew 77: #############################################
78: #############################################
79:
80: =pod
81:
1.9 ! raeburn 82: =item check_cookie_and_load_env()
1.1 matthew 83:
84: Inputs: none
85:
86: Returns: 1 if the user has a LON-CAPA cookie 0 if not.
1.3 albertel 87: Loads the users environment into the %env hash if the cookie is correct.
1.1 matthew 88:
89: =cut
90:
91: #############################################
92: #############################################
93: sub check_cookie_and_load_env {
94: my %cookies=fetch CGI::Cookie;
95: if (exists($cookies{'lonID'}) &&
96: -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
97: # cookie found
98: &transfer_profile_to_env($cookies{'lonID'}->value);
99: return 1;
100: } else {
101: # No cookie found
102: return 0;
103: }
104: }
105:
106: #############################################
107: #############################################
108:
109: =pod
110:
1.9 ! raeburn 111: =item check_cookie()
1.1 matthew 112:
113: Inputs: none
114:
115: Returns: 1 if the user has a LON-CAPA cookie and 0 if not.
116:
117: =cut
118:
119: #############################################
120: #############################################
121: sub check_cookie {
122: my %cookies=fetch CGI::Cookie;
123: if (exists($cookies{'lonID'}) &&
124: -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
125: # cookie found
126: return 1;
127: } else {
128: # No cookie found
129: return 0;
130: }
131: }
132:
133: #############################################
134: #############################################
135:
136: =pod
137:
1.9 ! raeburn 138: =item transfer_profile_to_env()
1.1 matthew 139:
1.3 albertel 140: Load the users environment into the %env hash.
1.1 matthew 141:
142: Inputs: $handle, the name of the users LON-CAPA cookie.
143:
144: Returns: undef
145:
146: =cut
147:
148: #############################################
149: #############################################
150: sub transfer_profile_to_env {
151: my ($handle)=@_;
1.8 albertel 152: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
153: 0640)) {
154: %Apache::lonnet::env = %disk_env;
155: untie(%disk_env);
1.1 matthew 156: }
1.4 albertel 157: $Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
1.1 matthew 158: return undef;
159: }
160:
161: #############################################
162: #############################################
163:
1.9 ! raeburn 164: =pod
! 165:
! 166: =item check_ipbased_access()
! 167:
! 168: Inputs: $page, the identifier of the page to be viewed,
! 169: can be one of the keys in the hash from &serverstatus_titles()
! 170:
! 171: $ip, the IP address of the client requesting the page.
! 172:
! 173: Returns: 1 if access is permitted for the requestor's IP.
! 174: Access is allowed if on of the following is true:
! 175: (a) the requestor IP is the loopback address
! 176: (b) Domain configurations for domains hosted on this server include
! 177: the requestor's IP as one of the specified IPs with access
! 178: to this page. (does not apply to 'ping' page type)
! 179: =cut
! 180:
! 181: #############################################
! 182: #############################################
! 183: sub check_ipbased_access {
! 184: my ($page,$ip) = @_;
! 185: my $allowed;
! 186: if (!defined($ip)) {
! 187: $ip = $ENV{'REMOTE_ADDR'};
! 188: }
! 189: if (($page ne 'lonstatus') && ($page ne 'serverstatus')) {
! 190: if ($ip eq '127.0.0.1') {
! 191: $allowed = 1;
! 192: return $allowed;
! 193: }
! 194: }
! 195: if ($page ne 'ping') {
! 196: my @poss_domains = &Apache::lonnet::current_machine_domains();
! 197: foreach my $dom (@poss_domains) {
! 198: my %domconfig = &Apache::lonnet::get_dom('configuration',['serverstatuses'],$dom);
! 199: if (ref($domconfig{'serverstatuses'}) eq 'HASH') {
! 200: if (ref($domconfig{'serverstatuses'}{$page}) eq 'HASH') {
! 201: if ($domconfig{'serverstatuses'}{$page}{'machines'} ne '') {
! 202: my @okmachines = split(/,/,$domconfig{'serverstatuses'}{$page}{'machines'});
! 203: if (grep(/^\Q$ip\E$/,@okmachines)) {
! 204: $allowed = 1;
! 205: last;
! 206: }
! 207: }
! 208: }
! 209: }
! 210: }
! 211: }
! 212: return $allowed;
! 213: }
! 214:
! 215: #############################################
! 216: #############################################
! 217:
! 218: =pod
! 219:
! 220: =item can_view()
! 221:
! 222: Inputs: $page, the identifier of the page to be viewed,
! 223: can be one of the keys in the hash from &serverstatus_titles()
! 224:
! 225: Returns: 1 if access to the page is permitted.
! 226: Access allowed if one of the following is true:
! 227: (a) Requestor has LON-CAPA superuser role
! 228: (b) Requestor's role is Domain Coordinator in one of the domains
! 229: hosted on this server
! 230: (c) Domain configurations for domains hosted on this server include
! 231: the requestor as one of the named users (username:domain) with access
! 232: to the page.
! 233:
! 234: In the case of requests for the 'ping' page, and access is also allowed if
! 235: at least one domain hosted on requestor's server is also hosted on this server.
! 236:
! 237: =cut
! 238:
! 239: #############################################
! 240: #############################################
! 241: sub can_view {
! 242: my ($page) = @_;
! 243: my $allowed;
! 244: if ($Apache::lonnet::env{'request.role'} =~ m{^su\./}) {
! 245: $allowed = 1;
! 246: } elsif ($page eq 'ping') {
! 247: my @poss_domains = &Apache::lonnet::current_machine_domains();
! 248: my @hostids= &Apache::lonnet::get_hosts_from_ip($ENV{'REMOTE_ADDR'});
! 249: foreach my $hostid (@hostids) {
! 250: my $hostdom = &Apache::lonnet::host_domain($hostid);
! 251: if (grep(/^\Q$hostdom\E$/,@poss_domains)) {
! 252: $allowed = 1;
! 253: last;
! 254: }
! 255: }
! 256: } else {
! 257: my @poss_domains = &Apache::lonnet::current_machine_domains();
! 258: foreach my $dom (@poss_domains) {
! 259: my %domconfig = &Apache::lonnet::get_dom('configuration',['serverstatuses'],$dom);
! 260: if ($Apache::lonnet::env{'request.role'} eq "dc./$dom/") {
! 261: $allowed = 1;
! 262: } elsif (ref($domconfig{'serverstatuses'}) eq 'HASH') {
! 263: if (ref($domconfig{'serverstatuses'}{$page}) eq 'HASH') {
! 264: if ($domconfig{'serverstatuses'}{$page}{'namedusers'} ne '') {
! 265: my @okusers = split(/,/,$domconfig{'serverstatuses'}{$page}{'namedusers'});
! 266: if (grep(/^\Q$Apache::lonnet::env{'user.name'}:$Apache::lonnet::env{'user.domain'}\E$/,@okusers)) {
! 267: $allowed = 1;
! 268: }
! 269: }
! 270: }
! 271: }
! 272: last if $allowed;
! 273: }
! 274: }
! 275: return $allowed;
! 276: }
! 277:
! 278: #############################################
! 279: #############################################
! 280:
! 281: =pod
! 282:
! 283: =unauthorized_msg()
! 284:
! 285: Inputs: $page, the identifier of the page to be viewed,
! 286: can be one of the keys in the hash from &serverstatus_titles()
! 287:
! 288: Returns: A string explaining why access was denied for the particular page.
! 289:
! 290: =cut
! 291:
! 292: #############################################
! 293: #############################################
! 294: sub unauthorized_msg {
! 295: my ($page) = @_;
! 296: my $titles = &serverstatus_titles();
! 297: if ($page eq 'clusterstatus') {
! 298: return &mt('Your current role does not permit you to view the requested server status page: [_1]',$titles->{$page});
! 299: }
! 300: my @poss_domains = &Apache::lonnet::current_machine_domains();
! 301: if (@poss_domains == 1) {
! 302: my $domdesc = &Apache::lonnet::domain($poss_domains[0]);
! 303: 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});
! 304: } elsif (@poss_domains > 1) {
! 305: my $output = &mt('Configurations for the domains housed on this server: ').'<ul>';
! 306: foreach my $dom (@poss_domains) {
! 307: my $domdesc = &Apache::lonnet::domain($dom);
! 308: $output .= '<li>'.&Apache::lonnet::domain($dom).'('.$dom.')</li>';
! 309: }
! 310: $output .= '</ul>'.&mt('do not permit you to view the requested server status page: [_1]',$titles->{$page});
! 311: return $output;
! 312: } else {
! 313: return &mt('No domain information exists for this server');
! 314: }
! 315: }
! 316:
! 317: #############################################
! 318: #############################################
! 319:
! 320: =pod
! 321:
! 322: =item missing_cookie_msg()
! 323:
! 324: Inputs: none
! 325: Returns: HTML for a page indicating cookie information absent.
! 326:
! 327: =cut
! 328:
! 329: #############################################
! 330: #############################################
! 331: sub missing_cookie_msg {
! 332: my %lt = &Apache::lonlocal::texthash (
! 333: cook => 'Bad Cookie',
! 334: your => 'Your cookie information is incorrect.',
! 335: );
! 336: return <<END;
! 337: <html>
! 338: <head><title>$lt{'cook'}</title></head>
! 339: <body>
! 340: $lt{'your'}
! 341: </body>
! 342: </html>
! 343: END
! 344:
! 345: }
! 346:
! 347: #############################################
! 348: #############################################
! 349:
! 350: =pod
! 351:
! 352: =item serverstatus_titles()
! 353:
! 354: Inputs: none
! 355:
! 356: Returns: a reference to a hash of pages, where in the hash
! 357: keys are names of pages which employ loncgi.pm
! 358: or lonstatusacc.pm for access control,
! 359: and corresponding values are descriptions of each page
! 360:
! 361: =cut
! 362:
! 363: #############################################
! 364: #############################################
! 365: sub serverstatus_titles {
! 366: my %titles = &Apache::lonlocal::texthash (
! 367: 'userstatus' => 'User Status Summary',
! 368: 'lonstatus' => 'Display Detailed Report',
! 369: 'loncron' => 'Generate Detailed Report',
! 370: 'server-status' => 'Apache Status Page',
! 371: 'codeversions' => 'LON-CAPA Module Versions',
! 372: 'clusterstatus' => 'Domain status',
! 373: 'metadata_keywords' => 'Display Metadata Keywords',
! 374: 'metadata_harvest' => 'Harvest Metadata Searches',
! 375: 'takeoffline' => 'Offline - replace Log-in page',
! 376: 'takeonline' => 'Online - restore Log-in page',
! 377: 'showenv' => "Show user environment",
! 378: );
! 379: return \%titles;
! 380: }
! 381:
! 382: #############################################
! 383: #############################################
! 384:
! 385: =pod
! 386:
! 387: =cgi_getitems()
! 388:
! 389: Inputs: $query (the CGI query string), and $getitems, a reference to a hash
! 390:
! 391: Returns: nothing
! 392:
! 393: Side Effects: populates $getitems hash ref with key => value
! 394: where each key is the name of the form item in the query string
! 395: and value is an array of corresponding values.
! 396: =cut
! 397:
! 398: #############################################
! 399: #############################################
! 400: sub cgi_getitems {
! 401: my ($query,$getitems)= @_;
! 402: foreach (split(/&/,$query)) {
! 403: my ($name, $value) = split(/=/,$_);
! 404: $name = &unescape($name);
! 405: $value =~ tr/+/ /;
! 406: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
! 407: push(@{$$getitems{$name}},$value);
! 408: }
! 409: return;
! 410: }
1.6 albertel 411:
1.1 matthew 412: =pod
413:
414: =back
415:
416: =cut
417:
418: 1;
419:
420: __END__
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to loncgi.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / cgi