Annotation of loncom/cgi/loncgi.pm, revision 1.10
1.1 matthew 1: #
2: # LON-CAPA helpers for cgi-bin scripts
3: #
1.10 ! raeburn 4: # $Id: loncgi.pm,v 1.9 2008/11/28 20:39:43 raeburn 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:
1.10 ! raeburn 84: Inputs: 1 ( optional). When called from a handler in mod_perl,
! 85: pass in the request object.
1.1 matthew 86:
87: Returns: 1 if the user has a LON-CAPA cookie 0 if not.
1.3 albertel 88: Loads the users environment into the %env hash if the cookie is correct.
1.1 matthew 89:
90: =cut
91:
92: #############################################
93: #############################################
94: sub check_cookie_and_load_env {
1.10 ! raeburn 95: my ($r) = @_;
! 96: my %cookies;
! 97: if (ref($r)) {
! 98: %cookies = CGI::Cookie->fetch($r);
! 99: } else {
! 100: %cookies = CGI::Cookie->fetch();
! 101: }
1.1 matthew 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:
1.9 raeburn 118: =item check_cookie()
1.1 matthew 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:
1.9 raeburn 145: =item transfer_profile_to_env()
1.1 matthew 146:
1.3 albertel 147: Load the users environment into the %env hash.
1.1 matthew 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)=@_;
1.8 albertel 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);
1.1 matthew 163: }
1.4 albertel 164: $Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
1.1 matthew 165: return undef;
166: }
167:
168: #############################################
169: #############################################
170:
1.9 raeburn 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: }
1.6 albertel 418:
1.1 matthew 419: =pod
420:
421: =back
422:
423: =cut
424:
425: 1;
426:
427: __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