[LON-CAPA-cvs] cvs: loncom /cgi lonauthcgi.pm loncgi.pm

[raeburn]

raeburn		Fri Oct 21 20:00:30 2011 EDT

  Modified files:              
    /loncom/cgi	loncgi.pm lonauthcgi.pm 
  Log:
  - New routine: loncgi::cgi_header() generates HTTP response headers using CGI.pm
  - New arg in lonauthcgi::can_view() - $domain (optional), 
    used if $page is needed for a specific domain.
  - New return value: either 1, or a &-separated list of domains for which access is 
    allowed.
  
  
Index: loncom/cgi/loncgi.pm
diff -u loncom/cgi/loncgi.pm:1.11 loncom/cgi/loncgi.pm:1.12
--- loncom/cgi/loncgi.pm:1.11	Thu Dec 25 01:51:03 2008
+++ loncom/cgi/loncgi.pm	Fri Oct 21 20:00:30 2011
@@ -1,7 +1,7 @@
 #
 # LON-CAPA helpers for cgi-bin scripts
 #
-# $Id: loncgi.pm,v 1.11 2008/12/25 01:51:03 raeburn Exp $
+# $Id: loncgi.pm,v 1.12 2011/10/21 20:00:30 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -54,8 +54,9 @@
 no warnings 'uninitialized';
 
 use lib '/home/httpd/lib/perl/';
-use CGI();
+use CGI qw(:standard);
 use CGI::Cookie();
+use MIME::Types();
 use Fcntl qw(:flock);
 use LONCAPA;
 use LONCAPA::Configuration();
@@ -223,6 +224,39 @@
     return;
 }
 
+#############################################
+#############################################
+
+=pod
+
+=cgi_header()
+
+Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
+        $nocache     - Boolean 1 = nocache
+Returns: HTTP Response headers constructed using CGI.pm
+
+=cut
+
+#############################################
+#############################################
+sub cgi_header {
+    my ($contenttype,$nocache) = @_;
+    my $mimetypes = MIME::Types->new;
+    my %headers;
+    if ($contenttype ne '') {
+        if ($mimetypes->type($contenttype) ne '') {
+            $headers{'-type'} = $contenttype;
+        }
+    }
+    if ($nocache) {
+       $headers{'-expires'} = 'now';
+    }
+    if (%headers) {
+        return CGI::header(%headers);
+    }
+    return;
+}
+
 =pod
 
 =back
Index: loncom/cgi/lonauthcgi.pm
diff -u loncom/cgi/lonauthcgi.pm:1.8 loncom/cgi/lonauthcgi.pm:1.9
--- loncom/cgi/lonauthcgi.pm:1.8	Mon Oct 17 17:23:25 2011
+++ loncom/cgi/lonauthcgi.pm	Fri Oct 21 20:00:30 2011
@@ -1,7 +1,7 @@
 #
 # LON-CAPA authorization for cgi-bin scripts
 #
-# $Id: lonauthcgi.pm,v 1.8 2011/10/17 17:23:25 raeburn Exp $
+# $Id: lonauthcgi.pm,v 1.9 2011/10/21 20:00:30 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -225,15 +225,19 @@
 
 Inputs: $page, the identifier of the page to be viewed,
         can be one of the keys in the hash from &serverstatus_titles()
+        $domain (optional), a specific domain for which the page is needed.  
 
-Returns: 1 if access to the page is permitted.
+Returns: 1 if access to the page is permitted, or &-separated list of domains
+         for which access is allowed, if $page is domconf, and not superuser.
          Access allowed if one of the following is true:
          (a) Requestor has LON-CAPA superuser role
-         (b) Requestor's role is Domain Coordinator in one of the domains
+         (b) Requestor's role is Domain Coordinator in requested domain 
+             (if specified) or (if unspecified) in one of the domains
              hosted on this server
-         (c) Domain configurations for domains hosted on this server include
-             the requestor as one of the named users (username:domain) with access
-             to the page.
+         (c) The domain configuration for the particular domain (if specified),
+             or domain configurations for domains hosted on this server (if 
+             specific domain not specified), include the requestor as one of
+             the named users (username:domain) with access to the page.
 
          In the case of requests for the 'showenv' page (/adm/test), the domains tested
          are not the domains hosted on the server, but instead are a single domain - 
@@ -246,7 +250,7 @@
 #############################################
 #############################################
 sub can_view {
-    my ($page) = @_;
+    my ($page,$domain) = @_;
     my $allowed;
     if ($Apache::lonnet::env{'request.role'} =~ m{^su\./}) {
         $allowed = 1;
@@ -267,25 +271,43 @@
             }
         } else {
             @poss_domains = &Apache::lonnet::current_machine_domains();
+            if ($domain ne '') {
+                if (grep(/^\Q$domain\E$/, at poss_domains)) {
+                    @poss_domains = ($domain);
+                } else {
+                    undef(@poss_domains); 
+                }
+            }
         }
         unless ($allowed) {
             foreach my $dom (@poss_domains) {
                 my %domconfig = &Apache::lonnet::get_dom('configuration',['serverstatuses'],
                                                          $dom);
                 if ($Apache::lonnet::env{'request.role'} eq "dc./$dom/") {
-                    $allowed = 1;
+                    if ($page eq 'domconf') {
+                        $allowed .= $dom.'&';
+                    } else {
+                        $allowed = 1; 
+                    }
                 } elsif (ref($domconfig{'serverstatuses'}) eq 'HASH') {
                     if (ref($domconfig{'serverstatuses'}{$page}) eq 'HASH') {
                         if ($domconfig{'serverstatuses'}{$page}{'namedusers'} ne '') {
                             my @okusers = split(/,/,$domconfig{'serverstatuses'}{$page}{'namedusers'});
                             if (grep(/^\Q$Apache::lonnet::env{'user.name'}:$Apache::lonnet::env{'user.domain'}\E$/, at okusers)) {
-                                $allowed = 1;
+                                if ($page eq 'domconf') {
+                                    $allowed .= $dom.'&';
+                                } else {
+                                    $allowed = 1;
+                                }
+                            }
+                            unless ($page eq 'domconf') {
+                                last if ($allowed);
                             }
                         }
                     }
                 }
-                last if $allowed;
             }
+            $allowed =~ s/\&$//;
         }
     }
     return $allowed;
@@ -362,6 +384,8 @@
                    'takeonline'        => 'Online - restore Log-in page',
                    'showenv'           => 'Show user environment',
                    'toggledebug'       => 'Toggle debug messages',
+                   'ping'              => 'Cause server to ping another server',   
+                   'domconf'           => 'Text Display of Domain Configuration',
                  );
     return \%titles;
 }