Annotation of loncom/automation/Autocreate.pl, revision 1.21

1.1       raeburn     1: #!/usr/bin/perl
                      2: #
                      3: # Automated Course Creation script
                      4: #
1.21    ! raeburn     5: # $Id: Autocreate.pl,v 1.20 2016/11/16 18:09:21 raeburn Exp $
1.9       raeburn     6: #
1.1       raeburn     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: #
1.12      raeburn    29: # Run as www. Called from an entry in /etc/cron.d/loncapa
                     30: # either with command line args:
1.1       raeburn    31: #
                     32: # www /home/httpd/perl/Autocreate.pl $dom $uname:$udom
                     33: #
1.12      raeburn    34: # where $dom is the name of the course domain, $uname and $udom are the
                     35: # username and domain of a Domain Coordinator in the domain.
                     36: #
                     37: # or without args (default) controlled by domain configuration settings:
                     38: #
                     39: # www /home/httpd/perl/Autocreate.pl  
1.1       raeburn    40: #
                     41:     use strict;
                     42:     use lib '/home/httpd/lib/perl';
                     43:     use Apache::lonnet;
1.6       raeburn    44:     use Apache::lonlocal;
1.12      raeburn    45:     use Apache::loncoursequeueadmin;
1.1       raeburn    46:     use LONCAPA::batchcreatecourse;
                     47:     use LONCAPA::Configuration;
1.11      raeburn    48:     use LONCAPA();
1.1       raeburn    49: 
                     50:     my $perlvarref = &LONCAPA::Configuration::read_conf('loncapa.conf');
                     51:     my $logfile = $$perlvarref{'lonDaemons'}.'/logs/autocreate.log';
1.12      raeburn    52:     my @machinedoms = sort(&Apache::lonnet::current_machine_domains());
                     53:     my @ids=&Apache::lonnet::current_machine_ids();
                     54:     my (@libids,@domains);
                     55:     foreach my $id (@ids) {
                     56:         if (&Apache::lonnet::is_library($id)) {
                     57:             push(@libids,$id);
                     58:         }
                     59:     }
                     60:     exit if (!@libids); 
                     61:     foreach my $dom (@machinedoms) {
                     62:         my $primary = &Apache::lonnet::domain($dom,'primary');
                     63:         if (grep(/^\Q$primary\E$/,@libids)) {
                     64:             unless (grep(/^\Q$dom\E$/,@domains)) {
                     65:                 push(@domains,$dom);
                     66:             }
                     67:         }
                     68:     }
                     69:     exit if (!@domains);
1.1       raeburn    70:     open (my $fh,">>$logfile");
                     71:     print $fh "********************\n".localtime(time)." Autocreation messages start --\n";
                     72:     my $wwwid=getpwnam('www');
                     73:     if ($wwwid!=$<) {
                     74:         my $emailto=$$perlvarref{'lonAdmEMail'};
                     75:         my $subj="LON: $$perlvarref{'lonHostID'} User ID mismatch";
                     76:         my $requestmail = "To: $emailto\n";
1.12      raeburn    77:         $requestmail .=
1.1       raeburn    78:         "Subject: LON: $$perlvarref{'lonHostID'} User ID mismatch\n".
1.12      raeburn    79:         "User ID mismatch. Autocreate.pl must be run as user www\n";
1.1       raeburn    80:         if ($emailto =~ /^[^\@]+\@[^\@]+$/) {
                     81:             if (open(MAIL, "|/usr/lib/sendmail -oi -t -odb")) {
                     82:                 print MAIL $requestmail;
                     83:                 close(MAIL);
                     84:                 print $fh "Autocreate.pl must be run as user www\n\n";
                     85:             } else {
1.12      raeburn    86:                 print $fh "Could not send notification e-mail to $emailto\n\n";
1.1       raeburn    87:             }
                     88:         } else {
                     89:             print $fh "Notification e-mail address for Administrator is not a valid e-mail address\n\n";
                     90:         }
                     91:         close($fh);
                     92:         exit;
                     93:     }
1.12      raeburn    94:     if (@ARGV) {
                     95: # check if specified course domain is a domain hosted on this library server.
                     96:         if (!grep(/^\Q$ARGV[0]\E$/,@domains)) {
                     97:             print $fh "The domain you supplied is not a valid domain for this server\n";
                     98:             close($fh);
                     99:             exit;
                    100:         } elsif (@ARGV < 2) {
                    101:             print $fh "usage: ./Autocreate <coursedomain  username:domain>.\nPlease provide the username and domain of a Domain Coordinator, if you provide a coursedomain.\nThe script can also be called without any arguments, in which case domain configuration data for domains hosted on this server will be used.\n";
                    102:             close($fh);
                    103:             exit;
                    104:         } else {
                    105:             my $defdom = $ARGV[0];
                    106:             my ($dcname,$dcdom) = ($ARGV[1] =~ /^([^:]+):([^:]+)$/);
                    107: # check if user is an active domain coordinator.
                    108:             if (!&check_activedc($dcdom,$dcname,$defdom)) {
                    109:                 print $fh "The username you supplied for domain $defdom does not have an active domain coordinator role in the domain\n\n";
                    110:                 close($fh);
                    111:                 exit;
                    112:             }
1.19      raeburn   113:             &set_dc_env($dcname,$dcdom,$defdom);
1.14      raeburn   114:             my @permissions = ('mau','ccc','cin','cta','cep','ccr','cst');
                    115:             my %permissionflags = ();
                    116:             &set_permissions(\%permissionflags,\@permissions);
1.12      raeburn   117:             my $output = &process_xml($fh,$defdom,$dcname,$dcdom);
1.19      raeburn   118:             &unset_permissions(\%permissionflags);
                    119:             &unset_dc_env();
1.12      raeburn   120:             print $output;
                    121:         }
                    122:     } else {
                    123:         my @permissions = ('mau','ccc','cin','cta','cep','ccr','cst');
                    124:         my %permissionflags = ();
                    125:         &set_permissions(\%permissionflags,\@permissions);
                    126:         foreach my $dom (@domains) {
                    127:             my %domconfig = &Apache::lonnet::get_dom('configuration',
                    128:                                                      ['autocreate'],$dom);
                    129:             #only run if configured to
                    130:             my $xml_update = 0;
                    131:             my $settings;
                    132:             if (ref($domconfig{'autocreate'}) eq 'HASH') {
                    133:                 $settings = $domconfig{'autocreate'};
1.18      raeburn   134:                 my ($dcname,$dcdom);
                    135:                 if ($settings->{'xmldc'}) {
                    136:                     ($dcname,$dcdom) = split(':',$settings->{'xmldc'});
                    137:                 }
1.12      raeburn   138:                 if ($settings->{'xml'}) {
                    139:                     if ($settings->{'xmldc'}) {
                    140:                         if (!&check_activedc($dcdom,$dcname,$dom)) {
                    141:                             print $fh "Autocreate.pl in domain $dom configured to run under the auspices of a user without an active domain coordinator role in the domain - course creation will be skipped.\n\n";
                    142:                             next;
                    143:                         } else {
                    144:                             &process_xml($fh,$dom,$dcname,$dcdom);
                    145:                         }
                    146:                     } else {
                    147:                         print $fh "Autocreate.pl in domain $dom - no specified DC under whose identity course creation will occur - domain skipped.\n\n";
                    148:                     }
                    149:                 }
                    150:                 if ($settings->{'req'}) {
1.19      raeburn   151:                     &set_dc_env($dcname,$dcdom);
1.17      raeburn   152:                     my $output = &Apache::loncoursequeueadmin::process_official_reqs('auto',$dom,$dcname,$dcdom);
1.19      raeburn   153:                     &unset_dc_env();
1.13      raeburn   154:                     if ($output) {
                    155:                         print $fh $output;
                    156:                     }
1.12      raeburn   157:                 }
                    158:             }
                    159:         }
                    160:         &unset_permissions(\%permissionflags);
                    161:     }
                    162:     print $fh "-- ".localtime(time)." Autocreation messages end\n*******************\n\n";
                    163:     close($fh);
                    164: 
                    165: 
                    166: sub process_xml {
                    167:     my ($fh,$dom,$dcname,$dcdom) = @_;
1.20      raeburn   168:     &set_dc_env($dcname,$dcdom,$dom);
1.12      raeburn   169:     # Initialize language handler
                    170:     &Apache::lonlocal::get_language_handle();
                    171: 
                    172:     my $batchdir = $$perlvarref{'lonDaemons'}.'/tmp/addcourse/'.$dom.'/auto';
                    173:     opendir(DIR,"$batchdir/pending");
                    174:     my @requests = grep(!/^\.\.?$/,readdir(DIR));
                    175:     closedir(DIR);
                    176:     my %courseids = ();
                    177:     print $fh "Sending to batch - auto,$dom,$dcname,$dcdom ".join(":",@requests)."\n";
1.21    ! raeburn   178:     my ($result,$logmsg,$keysmsg,$codesref,$instcodesref) =
        !           179:         &LONCAPA::batchcreatecourse::create_courses(\@requests,\%courseids,'auto',$dom,$dcname,$dcdom);
1.8       raeburn   180:     my $outcome;
1.7       raeburn   181:     if ($result ne '') {
1.8       raeburn   182:         $outcome = $result."\n";
1.7       raeburn   183:     }
                    184:     if ($logmsg ne '') {
1.8       raeburn   185:         $outcome .= $logmsg."\n";    
1.7       raeburn   186:     }
1.21    ! raeburn   187:     if ($keysmsg ne '') {
        !           188:         $outcome .=  $keysmsg."\n";
        !           189:     }
1.8       raeburn   190:     print $fh $outcome;
1.1       raeburn   191: 
1.8       raeburn   192:     my $output;
1.1       raeburn   193: # Copy requests from pending directory to processed directory and unlink.
1.8       raeburn   194:     foreach my $request (@requests) {  
1.1       raeburn   195:         if ((-e "$batchdir/pending/$request") && $request !~ /\.\./ && $request ne '' &&$request ne './') {
                    196:             open(FILE,"<$batchdir/pending/$request");
                    197:             my @buffer = <FILE>;
                    198:             close(FILE);
1.3       raeburn   199:             if (!-e "$batchdir/processed") {
                    200:                 mkdir("$batchdir/processed", 0755);
                    201:             }
1.1       raeburn   202:             open(FILE,">$batchdir/processed/$request");
                    203:             print FILE @buffer;
                    204:             close(FILE);
                    205:             if (-e "$batchdir/processed/$request") {
                    206:                 unlink("$batchdir/pending/$request");
                    207:             }
                    208:         }
                    209:     }
1.12      raeburn   210:     foreach my $key (sort(keys(%courseids))) {
1.3       raeburn   211:         print $fh "created course: $key - $courseids{$key}\n";
1.11      raeburn   212:         my $newcourse = &LONCAPA::escape($key.':'.$courseids{$key});
1.12      raeburn   213:         $output .= $newcourse.':';
1.1       raeburn   214:     }
1.3       raeburn   215:     $output =~ s/:$//;
1.19      raeburn   216:     &unset_dc_env();
1.21    ! raeburn   217:     if (ref($instcodesref) eq 'HASH') {
        !           218:         if (keys(%{$instcodesref}) > 0) {
        !           219:             &Apache::lonnet::devalidate_cache_new('instcats',$dom);
        !           220:             if (&Apache::lonnet::shared_institution($dom)) {
        !           221:                 my %servers = &Apache::lonnet::internet_dom_servers($dom);
        !           222:                 my %thismachine;
        !           223:                 map { $thismachine{$_} = 1; } &Apache::lonnet::current_machine_ids();
        !           224:                 if (keys(%servers)) {
        !           225:                     foreach my $server (keys(%servers)) {
        !           226:                         next if ($thismachine{$server});
        !           227:                         &Apache::lonnet::remote_devalidate_cache($server,['instcats:'.$dom]);
        !           228:                     }
        !           229:                 }
        !           230:             }
        !           231:         }
        !           232:     }
1.12      raeburn   233:     return $output;
                    234: }
                    235: 
1.1       raeburn   236: sub check_activedc {
                    237:     my ($dcdom,$dcname,$defdom) = @_;
1.16      raeburn   238:     my %roleshash = 
                    239:         &Apache::lonnet::get_my_roles($dcname,$dcdom,'userroles',undef,['dc'],[$defdom]);
                    240:     if (keys(%roleshash) > 0) {
                    241:         return 1;
1.1       raeburn   242:     }
1.16      raeburn   243:     return 0;
1.1       raeburn   244: }
1.3       raeburn   245: 
                    246: sub set_permissions {
                    247:     my ($permissionflags,$permissions) = @_;
                    248:     foreach my $allowtype (@{$permissions}) {
1.4       raeburn   249:         unless($env{"allowed.$allowtype"}) {
                    250:             $env{"allowed.$allowtype"} = 'F';
1.12      raeburn   251:             $permissionflags->{$allowtype} = 1;
1.3       raeburn   252:         }
                    253:     }
                    254: }
                    255: 
                    256: sub unset_permissions {
                    257:     my ($permissionflags) = @_;
1.12      raeburn   258:     foreach my $allowtype (keys(%{$permissionflags})) {
1.4       raeburn   259:         delete($env{"allowed.$allowtype"});
1.3       raeburn   260:     }
                    261: }
1.19      raeburn   262: 
                    263: sub set_dc_env {
                    264:     my ($dcname,$dcdom,$defdom) = @_;
                    265:     $env{'user.name'} = $dcname;
                    266:     $env{'user.domain'} = $dcdom;
                    267:     $env{'user.home'} = &Apache::lonnet::homeserver($dcname,$dcdom);
                    268:     if ($defdom ne '') {
                    269:         $env{'request.role.domain'} = $defdom;
                    270:     } 
                    271:     return;
                    272: }
                    273: 
                    274: sub unset_dc_env {
                    275:     delete($env{'user.name'});
                    276:     delete($env{'user.domain'});
                    277:     delete($env{'user.home'});
                    278:     if ($env{'request.role.domain'}) {
                    279:         delete($env{'request.role.domain'});
                    280:     }
                    281:     return;
                    282: }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>