[BACK]Return to Lond.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/Lond.pm between versions 1.3 and 1.19

version 1.3, 2012/04/26 20:00:57 version 1.19, 2022/02/14 02:48:49
Line 27 Line 27
 ###  ###
   
 #NOTE perldoc at the end of file  #NOTE perldoc at the end of file
   #TODO move remaining lond functions into this
   
 package LONCAPA::Lond;  package LONCAPA::Lond;
   
Line 36  use lib '/home/httpd/lib/perl/'; Line 37  use lib '/home/httpd/lib/perl/';
 use LONCAPA;  use LONCAPA;
 use Apache::lonnet;  use Apache::lonnet;
 use GDBM_File;  use GDBM_File;
   use MIME::Base64;
   use Crypt::OpenSSL::X509;
   use Crypt::X509::CRL;
   use Crypt::PKCS10;
   use Net::OAuth;
   
 sub dump_with_regexp {  sub dump_with_regexp {
     my ( $tail, $clientname, $clientversion ) = @_;      my ( $tail, $clientversion ) = @_;
     my ( $udom, $uname, $namespace, $regexp, $range ) =       my ( $udom, $uname, $namespace, $regexp, $range ) = 
         split /:/, $tail;          split /:/, $tail;
   
     $regexp = defined $regexp ? unescape($regexp) : '.';      $regexp = $regexp ? unescape($regexp) : '.';
   
     my ($start,$end);      my ($start,$end);
   
Line 79  sub dump_with_regexp { Line 84  sub dump_with_regexp {
         if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {          if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
             $major = $1;              $major = $1;
             $minor = $2;              $minor = $2;
   
         }          }
         if (($major > 2) || (($major == 2) && ($minor > 9))) {          if (($major > 2) || (($major == 2) && ($minor > 9))) {
             $skipcheck = 1;              $skipcheck = 1;
Line 237  sub check_homecourses { Line 243  sub check_homecourses {
                     }                      }
                 }                  }
                 unless (&untie_domain_hash($hashref)) {                  unless (&untie_domain_hash($hashref)) {
                     &logthis("Failed to untie tied hash for nohist_courseids.db for $domain");                      &Apache::lonnet::logthis("Failed to untie tied hash for nohist_courseids.db for $domain");
                 }                  }
             } else {              } else {
                 &logthis("Failed to tie hash for nohist_courseids.db for $domain");                  &Apache::lonnet::logthis("Failed to tie hash for nohist_courseids.db for $domain");
             }              }
         }          }
         foreach my $hashid (keys(%recent)) {          foreach my $hashid (keys(%recent)) {
Line 312  sub get_courseinfo_hash { Line 318  sub get_courseinfo_hash {
     };      };
     if ($@) {      if ($@) {
         if ($@ eq "timeout\n") {          if ($@ eq "timeout\n") {
             &logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");              &Apache::lonnet::logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
         } else {          } else {
             &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");              &Apache::lonnet::logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
         }          }
     } else {      } else {
         if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {          if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
Line 325  sub get_courseinfo_hash { Line 331  sub get_courseinfo_hash {
     return;      return;
 }  }
   
   sub dump_course_id_handler {
       my ($tail) = @_;
   
       my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
           $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
           $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
           $creationcontext,$domcloner,$hasuniquecode,$reqcrsdom,$reqinstcode) = split(/:/,$tail);
       my $now = time;
       my ($cloneruname,$clonerudom,%cc_clone);
       if (defined($description)) {
    $description=&unescape($description);
       } else {
    $description='.';
       }
       if (defined($instcodefilter)) {
           $instcodefilter=&unescape($instcodefilter);
       } else {
           $instcodefilter='.';
       }
       my ($ownerunamefilter,$ownerdomfilter);
       if (defined($ownerfilter)) {
           $ownerfilter=&unescape($ownerfilter);
           if ($ownerfilter ne '.' && defined($ownerfilter)) {
               if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
                    $ownerunamefilter = $1;
                    $ownerdomfilter = $2;
               } else {
                   $ownerunamefilter = $ownerfilter;
                   $ownerdomfilter = '';
               }
           }
       } else {
           $ownerfilter='.';
       }
   
       if (defined($coursefilter)) {
           $coursefilter=&unescape($coursefilter);
       } else {
           $coursefilter='.';
       }
       if (defined($typefilter)) {
           $typefilter=&unescape($typefilter);
       } else {
           $typefilter='.';
       }
       if (defined($regexp_ok)) {
           $regexp_ok=&unescape($regexp_ok);
       }
       if (defined($catfilter)) {
           $catfilter=&unescape($catfilter);
       }
       if (defined($cloner)) {
           $cloner = &unescape($cloner);
           ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/); 
       }
       if (defined($cc_clone_list)) {
           $cc_clone_list = &unescape($cc_clone_list);
           my @cc_cloners = split('&',$cc_clone_list);
           foreach my $cid (@cc_cloners) {
               my ($clonedom,$clonenum) = split(':',$cid);
               next if ($clonedom ne $udom); 
               $cc_clone{$clonedom.'_'.$clonenum} = 1;
           } 
       }
       if ($createdbefore ne '') {
           $createdbefore = &unescape($createdbefore);
       } else {
          $createdbefore = 0;
       }
       if ($createdafter ne '') {
           $createdafter = &unescape($createdafter);
       } else {
           $createdafter = 0;
       }
       if ($creationcontext ne '') {
           $creationcontext = &unescape($creationcontext);
       } else {
           $creationcontext = '.';
       }
       unless ($hasuniquecode) {
           $hasuniquecode = '.';
       }
       if ($reqinstcode ne '') {
           $reqinstcode = &unescape($reqinstcode);
       }
       my $unpack = 1;
       if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && 
           $typefilter eq '.') {
           $unpack = 0;
       }
       if (!defined($since)) { $since=0; }
       my (%gotcodedefaults,%otcodedefaults);
       my $qresult='';
   
       my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT())
           or return "error: ".($!+0)." tie(GDBM) Failed while attempting courseiddump";
   
    while (my ($key,$value) = each(%$hashref)) {
               my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
                   %unesc_val,$selfenroll_end,$selfenroll_types,$created,
                   $context);
               $unesc_key = &unescape($key);
               if ($unesc_key =~ /^lasttime:/) {
                   next;
               } else {
                   $lasttime_key = &escape('lasttime:'.$unesc_key);
               }
               if ($hashref->{$lasttime_key} ne '') {
                   $lasttime = $hashref->{$lasttime_key};
                   next if ($lasttime<$since);
               }
               my ($canclone,$valchange,$clonefromcode);
               my $items = &Apache::lonnet::thaw_unescape($value);
               if (ref($items) eq 'HASH') {
                   if ($hashref->{$lasttime_key} eq '') {
                       next if ($since > 1);
                   }
                   if ($items->{'inst_code'}) {
                       $clonefromcode = $items->{'inst_code'};
                   }
                   $is_hash =  1;
                   if ($domcloner) {
                       $canclone = 1;
                   } elsif (defined($clonerudom)) {
                       if ($items->{'cloners'}) {
                           my @cloneable = split(',',$items->{'cloners'});
                           if (@cloneable) {
                               if (grep(/^\*$/,@cloneable))  {
                                   $canclone = 1;
                               } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
                                   $canclone = 1;
                               } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
                                   $canclone = 1;
                               }
                           }
                           unless ($canclone) {
                               if ($cloneruname ne '' && $clonerudom ne '') {
                                   if ($cc_clone{$unesc_key}) {
                                       $canclone = 1;
                                       $items->{'cloners'} .= ','.$cloneruname.':'.
                                                              $clonerudom;
                                       $valchange = 1;
                                   }
                               }
                           }
                           unless ($canclone) {
                               if (($reqcrsdom eq $udom) && ($reqinstcode) && ($clonefromcode)) {
                                   if (grep(/\=/,@cloneable))  {
                                       foreach my $cloner (@cloneable) {
                                           if (($cloner ne '*') && ($cloner !~ /^\*\:$LONCAPA::match_domain$/) &&
                                               ($cloner !~ /^$LONCAPA::match_username\:$LONCAPA::match_domain$/) && ($cloner ne '')) {
                                               if ($cloner =~ /=/) {
                                                   my (%codedefaults,@code_order);
                                                   if (ref($gotcodedefaults{$udom}) eq 'HASH') {
                                                       if (ref($gotcodedefaults{$udom}{'defaults'}) eq 'HASH') {
                                                           %codedefaults = %{$gotcodedefaults{$udom}{'defaults'}};
                                                       }
                                                       if (ref($gotcodedefaults{$udom}{'order'}) eq 'ARRAY') {
                                                           @code_order = @{$gotcodedefaults{$udom}{'order'}};
                                                       }
                                                   } else {
                                                       &Apache::lonnet::auto_instcode_defaults($udom,
                                                                                               \%codedefaults,
                                                                                               \@code_order);
                                                       $gotcodedefaults{$udom}{'defaults'} = \%codedefaults;
                                                       $gotcodedefaults{$udom}{'order'} = \@code_order;
                                                   }
                                                   if (@code_order > 0) {
                                                       if (&Apache::lonnet::check_instcode_cloning(\%codedefaults,\@code_order,
                                                                                                   $cloner,$clonefromcode,$reqinstcode)) {
                                                           $canclone = 1;
                                                           last;
                                                       }
                                                   }
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                       } elsif (defined($cloneruname)) {
                           if ($cc_clone{$unesc_key}) {
                               $canclone = 1;
                               $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                               $valchange = 1;
                           }
                           unless ($canclone) {
                               if ($items->{'owner'} =~ /:/) {
                                   if ($items->{'owner'} eq $cloner) {
                                       $canclone = 1;
                                   }
                               } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
                                   $canclone = 1;
                               }
                               if ($canclone) {
                                   $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                                   $valchange = 1;
                               }
                           }
                       }
                       unless (($canclone) || ($items->{'cloners'})) {
                           my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
                           if ($domdefs{'canclone'}) {
                               unless ($domdefs{'canclone'} eq 'none') {
                                   if ($domdefs{'canclone'} eq 'domain') {
                                       if ($clonerudom eq $udom) {
                                           $canclone = 1;
                                       }
                                   } elsif (($clonefromcode) && ($reqinstcode) &&
                                            ($udom eq $reqcrsdom)) {
                                       if (&Apache::lonnet::default_instcode_cloning($udom,$domdefs{'canclone'},
                                                                                     $clonefromcode,$reqinstcode)) {
                                           $canclone = 1;
                                       }
                                   }
                               }
                           }
                       }
                   }
                   if ($unpack || !$rtn_as_hash) {
                       $unesc_val{'descr'} = $items->{'description'};
                       $unesc_val{'inst_code'} = $items->{'inst_code'};
                       $unesc_val{'owner'} = $items->{'owner'};
                       $unesc_val{'type'} = $items->{'type'};
                       $unesc_val{'cloners'} = $items->{'cloners'};
                       $unesc_val{'created'} = $items->{'created'};
                       $unesc_val{'context'} = $items->{'context'};
                   }
                   $selfenroll_types = $items->{'selfenroll_types'};
                   $selfenroll_end = $items->{'selfenroll_end_date'};
                   $created = $items->{'created'};
                   $context = $items->{'context'};
                   if ($selfenrollonly) {
                       next if (!$selfenroll_types);
                       if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
                           next;
                       }
                   }
                   if ($creationcontext ne '.') {
                       next if (($context ne '') && ($context ne $creationcontext));  
                   }
                   if ($createdbefore > 0) {
                       next if (($created eq '') || ($created > $createdbefore));   
                   }
                   if ($createdafter > 0) {
                       next if (($created eq '') || ($created <= $createdafter)); 
                   }
                   if ($catfilter ne '') {
                       next if ($items->{'categories'} eq '');
                       my @categories = split('&',$items->{'categories'}); 
                       next if (@categories == 0);
                       my @subcats = split('&',$catfilter);
                       my $matchcat = 0;
                       foreach my $cat (@categories) {
                           if (grep(/^\Q$cat\E$/,@subcats)) {
                               $matchcat = 1;
                               last;
                           }
                       }
                       next if (!$matchcat);
                   }
                   if ($caller eq 'coursecatalog') {
                       if ($items->{'hidefromcat'} eq 'yes') {
                           next if !$showhidden;
                       }
                   }
                   if ($hasuniquecode ne '.') {
                       next unless ($items->{'uniquecode'});
                   }
               } else {
                   next if ($catfilter ne '');
                   next if ($selfenrollonly);
                   next if ($createdbefore || $createdafter);
                   next if ($creationcontext ne '.');
                   if ((defined($clonerudom)) && (defined($cloneruname)))  {
                       if ($cc_clone{$unesc_key}) {
                           $canclone = 1;
                           $val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
                       }
                   }
                   $is_hash =  0;
                   my @courseitems = split(/:/,$value);
                   $lasttime = pop(@courseitems);
                   if ($hashref->{$lasttime_key} eq '') {
                       next if ($lasttime<$since);
                   }
           ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
               }
               if ($cloneonly) {
                  next unless ($canclone);
               }
               my $match = 1;
       if ($description ne '.') {
                   if (!$is_hash) {
                       $unesc_val{'descr'} = &unescape($val{'descr'});
                   }
                   if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
                       $match = 0;
                   }
               }
               if ($instcodefilter ne '.') {
                   if (!$is_hash) {
                       $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
                   }
                   if ($regexp_ok == 1) {
                       if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
                           $match = 0;
                       }
                   } elsif ($regexp_ok == -1) {
                       if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
                           $match = 0;
                       }
                   } else {
                       if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
                           $match = 0;
                       }
                   }
       }
               if ($ownerfilter ne '.') {
                   if (!$is_hash) {
                       $unesc_val{'owner'} = &unescape($val{'owner'});
                   }
                   if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ 
                                /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
                               $match = 0;
                           } 
                       } else {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                               $match = 0;
                           }
                       }
                   } elsif ($ownerunamefilter ne '') {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
                                $match = 0;
                           }
                       } else {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                               $match = 0;
                           }
                       }
                   } elsif ($ownerdomfilter ne '') {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
                                $match = 0;
                           }
                       } else {
                           if ($ownerdomfilter ne $udom) {
                               $match = 0;
                           }
                       }
                   }
               }
               if ($coursefilter ne '.') {
                   if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
                       $match = 0;
                   }
               }
               if ($typefilter ne '.') {
                   if (!$is_hash) {
                       $unesc_val{'type'} = &unescape($val{'type'});
                   }
                   if ($unesc_val{'type'} eq '') {
                       if ($typefilter ne 'Course') {
                           $match = 0;
                       }
                   } else {
                       if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
                           $match = 0;
                       }
                   }
               }
               if ($match == 1) {
                   if ($rtn_as_hash) {
                       if ($is_hash) {
                           if ($valchange) {
                               my $newvalue = &Apache::lonnet::freeze_escape($items);
                               $qresult.=$key.'='.$newvalue.'&';
                           } else {
                               $qresult.=$key.'='.$value.'&';
                           }
                       } else {
                           my %rtnhash = ( 'description' => &unescape($val{'descr'}),
                                           'inst_code' => &unescape($val{'inst_code'}),
                                           'owner'     => &unescape($val{'owner'}),
                                           'type'      => &unescape($val{'type'}),
                                           'cloners'   => &unescape($val{'cloners'}),
                                         );
                           my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
                           $qresult.=$key.'='.$items.'&';
                       }
                   } else {
                       if ($is_hash) {
                           $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
                                       &escape($unesc_val{'inst_code'}).':'.
                                       &escape($unesc_val{'owner'}).'&';
                       } else {
                           $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
                                       ':'.$val{'owner'}.'&';
                       }
                   }
               }
    }
       &untie_domain_hash($hashref) or 
           return "error: ".($!+0)." untie(GDBM) Failed while attempting courseiddump";
   
       chop($qresult);
       return $qresult;
   }
   
   sub dump_profile_database {
       my ($tail) = @_;
   
       my ($udom,$uname,$namespace) = split(/:/,$tail);
   
       my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or
           return "error: ".($!+0)." tie(GDBM) Failed while attempting currentdump";
   
    # Structure of %data:
    # $data{$symb}->{$parameter}=$value;
    # $data{$symb}->{'v.'.$parameter}=$version;
    # since $parameter will be unescaped, we do not
     # have to worry about silly parameter names...
   
           my $qresult='';
    my %data = ();                     # A hash of anonymous hashes..
    while (my ($key,$value) = each(%$hashref)) {
       my ($v,$symb,$param) = split(/:/,$key);
       next if ($v eq 'version' || $symb eq 'keys');
       next if (exists($data{$symb}) && 
        exists($data{$symb}->{$param}) &&
        $data{$symb}->{'v.'.$param} > $v);
       $data{$symb}->{$param}=$value;
       $data{$symb}->{'v.'.$param}=$v;
    }
   
       &untie_user_hash($hashref) or
           return "error: ".($!+0)." untie(GDBM) Failed while attempting currentdump";
   
       while (my ($symb,$param_hash) = each(%data)) {
       while(my ($param,$value) = each (%$param_hash)){
           next if ($param =~ /^v\./);       # Ignore versions...
           #
           #   Just dump the symb=value pairs separated by &
           #
           $qresult.=$symb.':'.$param.'='.$value.'&';
       }
       }
   
       chop($qresult);
       return $qresult;
   }
   
   sub is_course {
       my ($cdom,$cnum) = @_;
   
       return unless (($cdom =~ /^$LONCAPA::match_domain$/) &&
                      ($cnum =~ /^$LONCAPA::match_courseid$/));
       my $hashid = $cdom.':'.$cnum;
       my ($iscourse,$cached) =
           &Apache::lonnet::is_cached_new('iscourse',$hashid);
       unless (defined($cached)) {
           my $hashref =
               &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
           if (ref($hashref) eq 'HASH') {
               my $esc_key = &escape($cdom.'_'.$cnum);
               if (exists($hashref->{$esc_key})) {
                   $iscourse = 1;
               } else {
                   $iscourse = 0;
               }
               &Apache::lonnet::do_cache_new('iscourse',$hashid,$iscourse,3600);
               unless (&untie_domain_hash($hashref)) {
                   &Apache::lonnet::logthis("Failed to untie tied hash for nohist_courseids.db for $cdom");
               }
           } else {
               &Apache::lonnet::logthis("Failed to tie hash for nohist_courseids.db for $cdom");
           }
       }
       return $iscourse;
   }
   
   sub server_certs {
       my ($perlvar,$lonhost,$hostname) = @_;
       my %pemfiles = (
                        key      => 'lonnetPrivateKey',
                        host     => 'lonnetCertificate',
                        hostname => 'lonnetHostnameCertificate',
                        ca       => 'lonnetCertificateAuthority',
                        crl      => 'lonnetCertRevocationList',
                      );
       my (%md5hash,%expected_cn,%expired,%revoked,%wrongcn,%info,$crlfile,$cafile,
           %rvkcerts,$numrvk);
       %info = (
                   key => {},
                   ca  => {},
                   host => {},
                   hostname => {},
                   crl => {},
               );
       my @ordered = ('crl','key','ca','host','hostname');
       if (ref($perlvar) eq 'HASH') {
           $expected_cn{'host'} = $Apache::lonnet::serverhomeIDs{$hostname};
           $expected_cn{'hostname'} = 'internal-'.$hostname;
           my $certsdir = $perlvar->{'lonCertificateDirectory'};
           if (-d $certsdir) {
               $crlfile = $certsdir.'/'.$perlvar->{$pemfiles{'crl'}};
               $cafile = $certsdir.'/'.$perlvar->{$pemfiles{'ca'}};
               foreach my $key (@ordered) {
                   if ($perlvar->{$pemfiles{$key}}) {
                       my $file = $certsdir.'/'.$perlvar->{$pemfiles{$key}};
                       if (-e $file) {
                           if ($key eq 'crl') {
                                if ((-e $crlfile) && (-e $cafile)) {
                                    if (open(PIPE,"openssl crl -in $crlfile -inform pem -CAfile $cafile -noout 2>&1 |")) {
                                        my $crlstatus = <PIPE>;
                                        close(PIPE);
                                        chomp($crlstatus);
                                        if ($crlstatus =~ /OK/) {
                                            $info{$key}{'status'} = 'ok';
                                            $info{$key}{'details'} = 'CRL valid for CA';
                                        }
                                    }
                                }
                                if (open(my $fh,'<',$crlfile)) {
                                    my $pem_crl = '';
                                    while (my $line=<$fh>) {
                                        chomp($line);
                                        next if ($line eq '-----BEGIN X509 CRL-----');
                                        next if ($line eq '-----END X509 CRL-----');
                                        $pem_crl .= $line;
                                    }
                                    close($fh);
                                    my $der_crl = MIME::Base64::decode_base64($pem_crl);
                                    if ($der_crl ne '') {
                                        my $decoded = Crypt::X509::CRL->new( crl => $der_crl );
                                        if ($decoded->error) {
                                            $info{$key}{'status'} = 'error';
                                        } elsif (ref($decoded)) {
                                            $info{$key}{'start'} = $decoded->this_update;
                                            $info{$key}{'end'} = $decoded->next_update;
                                            $info{$key}{'alg'} = $decoded->SigEncAlg.' '.$decoded->SigHashAlg;
                                            $info{$key}{'cn'} = $decoded->issuer_cn;
                                            $info{$key}{'email'} = $decoded->issuer_email;
                                            $info{$key}{'size'} = $decoded->signature_length;
                                            my $rlref = $decoded->revocation_list;
                                            if (ref($rlref) eq 'HASH') {
                                                foreach my $key (keys(%{$rlref})) {
                                                    my $hkey = sprintf("%X",$key);
                                                    $rvkcerts{$hkey} = 1;
                                                }
                                                $numrvk = scalar(keys(%{$rlref}));
                                                if ($numrvk) {
                                                    $info{$key}{'details'} .= " ($numrvk revoked)"; 
                                                }
                                            }
                                        }
                                    }
                               }
                           } elsif ($key eq 'key') {
                               if (open(PIPE,"openssl rsa -noout -in $file -check |")) {
                                   my $check = <PIPE>;
                                   close(PIPE);
                                   chomp($check);
                                   $info{$key}{'status'} = $check;
                               }
                               if (open(PIPE,"openssl rsa -noout -modulus -in $file | openssl md5 |")) {
                                   $md5hash{$key} = <PIPE>;
                                   close(PIPE);
                                   chomp($md5hash{$key});
                               }
                           } else {
                               if ($key eq 'ca') {
                                   if (open(PIPE,"openssl verify -CAfile $file $file |")) {
                                       my $check = <PIPE>;
                                       close(PIPE);
                                       chomp($check);
                                       if ($check eq "$file: OK") {
                                           $info{$key}{'status'} = 'ok';
                                       } else {
                                           $check =~ s/^\Q$file\E\:?\s*//;
                                           $info{$key}{'status'} = $check;
                                       }
                                   }
                               } else {
                                   if (open(PIPE,"openssl x509 -noout -modulus -in $file | openssl md5 |")) {
                                       $md5hash{$key} = <PIPE>;
                                       close(PIPE);
                                       chomp($md5hash{$key});
                                   }
                               }
                               my $x509 = Crypt::OpenSSL::X509->new_from_file($file);
                               my @items = split(/,\s+/,$x509->subject());
                               foreach my $item (@items) {
                                   my ($name,$value) = split(/=/,$item);
                                   if ($name eq 'CN') {
                                       $info{$key}{'cn'} = $value;
                                   }
                               }
                               $info{$key}{'start'} = $x509->notBefore();
                               $info{$key}{'end'} = $x509->notAfter();
                               $info{$key}{'alg'} = $x509->sig_alg_name();
                               $info{$key}{'size'} = $x509->bit_length();
                               $info{$key}{'email'} = $x509->email();
                               $info{$key}{'serial'} = uc($x509->serial());
                               $info{$key}{'issuerhash'} = $x509->issuer_hash();
                               if ($x509->checkend(0)) {
                                   $expired{$key} = 1;
                               }
                               if (($key eq 'host') || ($key eq 'hostname')) {
                                   if ($info{$key}{'cn'} ne $expected_cn{$key}) {
                                       $wrongcn{$key} = 1;
                                   }
                                   if (($numrvk) && ($info{$key}{'serial'})) {
                                       if ($rvkcerts{$info{$key}{'serial'}}) {
                                           $revoked{$key} = 1;
                                       }
                                   }
                               }
                           }
                       }
                       if (($key eq 'host') || ($key eq 'hostname')) {
                           my $csrfile = $file;
                           $csrfile =~ s/\.pem$/.csr/;
                           if (-e $csrfile) {
                               if (open(PIPE,"openssl req -noout -modulus -in $csrfile |openssl md5 |")) {
                                   my $csrhash = <PIPE>;
                                   close(PIPE);
                                   chomp($csrhash);
                                   if ((!-e $file) || ($csrhash ne $md5hash{$key}) || ($expired{$key}) ||
                                       ($wrongcn{$key}) || ($revoked{$key})) {
                                       Crypt::PKCS10->setAPIversion(1);
                                       my $decoded = Crypt::PKCS10->new( $csrfile,(PEMonly => 1, readFile => 1));
                                       if (ref($decoded)) {
                                           if ($decoded->commonName() eq $expected_cn{$key}) {
                                               $info{$key.'-csr'}{'cn'} = $decoded->commonName();
                                               $info{$key.'-csr'}{'alg'} = $decoded->pkAlgorithm();
                                               $info{$key.'-csr'}{'email'} = $decoded->emailAddress();
                                               my $params = $decoded->subjectPublicKeyParams();
                                               if (ref($params) eq 'HASH') {
                                                   $info{$key.'-csr'}{'size'} = $params->{keylen};
                                               }
                                               $md5hash{$key.'-csr'} = $csrhash;
                                           }
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       foreach my $key ('host','hostname') {
           if ($md5hash{$key}) {
               if ($md5hash{$key} eq $md5hash{'key'}) {
                   if ($revoked{$key}) {
                       $info{$key}{'status'} = 'revoked';
                   } elsif ($expired{$key}) {
                       $info{$key}{'status'} = 'expired';
                   } elsif ($wrongcn{$key}) {
                       $info{$key}{'status'} = 'wrongcn';
                   } elsif ((exists($info{'ca'}{'issuerhash'})) &&
                            ($info{'ca'}{'issuerhash'} ne $info{$key}{'issuerhash'})) {
                       $info{$key}{'status'} = 'mismatch';
                   } else {
                       $info{$key}{'status'} = 'ok';
                   }
               } elsif ($info{'key'}{'status'} =~ /ok/) {
                   $info{$key}{'status'} = 'otherkey';
               } else {
                   $info{$key}{'status'} = 'nokey';
               }
           }
           if ($md5hash{$key.'-csr'}) {
               if ($md5hash{$key.'-csr'} eq $md5hash{'key'}) {
                   $info{$key.'-csr'}{'status'} = 'ok';
               } elsif ($info{'key'}{'status'} =~ /ok/) {
                   $info{$key.'-csr'}{'status'} = 'otherkey';
               } else {
                   $info{$key.'-csr'}{'status'} = 'nokey';
               }
           }
       }
       my $result;
       foreach my $key (keys(%info)) {
           $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($info{$key}).'&';
       }
       $result =~ s/\&$//;
       return $result;
   }
   
   sub get_dom {
       my ($userinput) = @_;
       my ($cmd,$udom,$namespace,$what) =split(/:/,$userinput,4); 
       my $hashref = &tie_domain_hash($udom,$namespace,&GDBM_READER()) or
           return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd";
       my $qresult='';
       if (ref($hashref)) {
           chomp($what);
           my @queries=split(/\&/,$what);
           for (my $i=0;$i<=$#queries;$i++) {
               $qresult.="$hashref->{$queries[$i]}&";
           }
           $qresult=~s/\&$//;
       }
       &untie_user_hash($hashref) or
           return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd";
       return $qresult;
   }
   
   sub store_dom {
       my ($userinput) = @_;
       my ($cmd,$dom,$namespace,$rid,$what) =split(/:/,$userinput);
       my $hashref  = &tie_domain_hash($dom,$namespace,&GDBM_WRCREAT(),"S","$rid:$what") or
           return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd";
       $hashref->{"version:$rid"}++;
       my $version=$hashref->{"version:$rid"};
       my $allkeys='';
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
           my ($key,$value)=split(/=/,$pair);
           $allkeys.=$key.':';
           $hashref->{"$version:$rid:$key"}=$value;
       }
       my $now = time;
       $hashref->{"$version:$rid:timestamp"}=$now;
       $allkeys.='timestamp';
       $hashref->{"$version:keys:$rid"}=$allkeys;
       &untie_user_hash($hashref) or
           return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd";    
       return 'ok';
   }
   
   sub restore_dom {
       my ($userinput) = @_;
       my ($cmd,$dom,$namespace,$rid) = split(/:/,$userinput);
       my $hashref = &tie_domain_hash($dom,$namespace,&GDBM_READER()) or
           return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd";
       my $qresult='';
       if (ref($hashref)) {
           chomp($rid);
           my $version=$hashref->{"version:$rid"};
           $qresult.="version=$version&";
           my $scope;
           for ($scope=1;$scope<=$version;$scope++) {
               my $vkeys=$hashref->{"$scope:keys:$rid"};
               my @keys=split(/:/,$vkeys);
               my $key;
               $qresult.="$scope:keys=$vkeys&";
               foreach $key (@keys) {
                   $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
               }
           }
           $qresult=~s/\&$//;
       }
       &untie_user_hash($hashref) or
           return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd";
       return $qresult;
   }
   
   sub crslti_itemid {
       my ($cdom,$cnum,$url,$method,$params,$loncaparev) = @_;
       unless (ref($params) eq 'HASH') {
           return;
       }
       if (($cdom eq '') || ($cnum eq '')) {
           return;
       }
       my ($itemid,$consumer_key,$secret);
   
       if (exists($params->{'oauth_callback'})) {
           $Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0A;
       } else {
           $Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0;
       }
   
       my $consumer_key = $params->{'oauth_consumer_key'};
       return if ($consumer_key eq '');
   
       my (%crslti,%crslti_by_key);
       my $hashid=$cdom.'_'.$cnum;
       my ($result,$cached)=&Apache::lonnet::is_cached_new('courseltienc',$hashid);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               %crslti = %{$result};
           }
       } else {
           my $reply = &dump_with_regexp(join(":",($cdom,$cnum,'nohist_ltienc','','')),$loncaparev);
           %crslti = %{&Apache::lonnet::unserialize($reply)};
           my $cachetime = 24*60*60;
           &Apache::lonnet::do_cache_new('courseltienc',$hashid,\%crslti,$cachetime);
       }
   
       return if (!keys(%crslti));
   
       foreach my $id (keys(%crslti)) {
           if (ref($crslti{$id}) eq 'HASH') {
               my $key = $crslti{$id}{'key'};
               if (($key ne '') && ($crslti{$id}{'secret'} ne '')) {
                   push(@{$crslti_by_key{$key}},$id);
               }
           }
       }
   
       return if (!keys(%crslti_by_key));
   
       if (ref($crslti_by_key{$consumer_key}) eq 'ARRAY') {
           foreach my $id (@{$crslti_by_key{$consumer_key}}) {
               my $secret = $crslti{$id}{'secret'};
               my $request = Net::OAuth->request('request token')->from_hash($params,
                                                 request_url => $url,
                                                 request_method => $method,
                                                 consumer_secret => $secret,);
               if ($request->verify()) {
                   $itemid = $id;
                   last;
               }
           }
       }
       return $itemid;
   }
   
   sub domlti_itemid {
       my ($dom,$context,$url,$method,$params,$loncaparev) = @_;
       unless (ref($params) eq 'HASH') {
           return;
       }
       if ($dom eq '') {
           return;
       }
       my ($itemid,$consumer_key,$secret);
   
       if (exists($params->{'oauth_callback'})) {
           $Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0A;
       } else {
           $Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0;
       }
   
       my $consumer_key = $params->{'oauth_consumer_key'};
       return if ($consumer_key eq '');
   
       my %ltienc;
       my ($encresult,$enccached)=&Apache::lonnet::is_cached_new('ltienc',$dom);
       if (defined($enccached)) {
           if (ref($encresult) eq 'HASH') {
               %ltienc = %{$encresult};
           }
       } else {
           my $reply = &get_dom("getdom:$dom:encconfig:lti");
           my $ltiencref = &Apache::lonnet::thaw_unescape($reply);
           if (ref($ltiencref) eq 'HASH') {
               %ltienc = %{$ltiencref};
           }
           my $cachetime = 24*60*60;
           &Apache::lonnet::do_cache_new('ltienc',$dom,\%ltienc,$cachetime);
       }
   
       return if (!keys(%ltienc));
   
       my %lti;
       if ($context eq 'deeplink') {
           my ($result,$cached)=&Apache::lonnet::is_cached_new('lti',$dom);
           if (defined($cached)) {
               if (ref($result) eq 'HASH') {
                   %lti = %{$result};
               }
           } else {
               my $reply = &get_dom("getdom:$dom:configuration:lti");
               my $ltiref = &Apache::lonnet::thaw_unescape($reply);
               if (ref($ltiref) eq 'HASH') {
                   %lti = %{$ltiref};
               }
               my $cachetime = 24*60*60;
               &Apache::lonnet::do_cache_new('lti',$dom,\%lti,$cachetime);
           }
       }
       return if (!keys(%lti));
   
       my %lti_by_key;
       foreach my $id (keys(%ltienc)) {
           if (ref($ltienc{$id}) eq 'HASH') {
               my $key = $ltienc{$id}{'key'};
               if (($key ne '') && ($ltienc{$id}{'secret'} ne '')) {
                   if ($context eq 'deeplink') {
                       if (ref($lti{$id}) eq 'HASH') {
                           if (!$lti{$id}{'requser'}) {
                               push(@{$lti_by_key{$key}},$id);
                           }
                       }
                   } else {
                       push(@{$lti_by_key{$key}},$id);
                   }
               }
           }
       }
       return if (!keys(%lti_by_key));
   
       if (ref($lti_by_key{$consumer_key}) eq 'ARRAY') {
           foreach my $id (@{$lti_by_key{$consumer_key}}) {
               my $secret = $ltienc{$id}{'secret'};
               my $request = Net::OAuth->request('request token')->from_hash($params,
                                                 request_url => $url,
                                                 request_method => $method,
                                                 consumer_secret => $secret,);
               if ($request->verify()) {
                   $itemid = $id;
                   last;
               }
           }
       }
       return $itemid;
   }
   
 1;  1;
   
Line 387  Returns: 1 (Continue processing). Line 1306  Returns: 1 (Continue processing).
   
 Side effects: response is written to $client.    Side effects: response is written to $client.  
   
   =item dump_course_id_handler
   
   #TODO copy from lond
   
   =item dump_profile_database
   
   #TODO copy from lond  
   
 =item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor,   =item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor, 
         $homecourses, $ids )          $homecourses, $ids )
Line 443  courseID -- for the course for which the Line 1369  courseID -- for the course for which the
 The contents of the inner hash, for that single item in the outer hash  The contents of the inner hash, for that single item in the outer hash
 are returned (and cached in memcache for 10 minutes).  are returned (and cached in memcache for 10 minutes).
   
   =item get_dom ( $userinput )
   
   get_dom() will retrieve domain configuration information from a GDBM file
   in /home/httpd/lonUsers/$dom on the primary library server in a domain.
   The single argument passed is the string: $cmd:$udom:$namespace:$what
   where $cmd is the command historically passed to lond - i.e., getdom
   or egetdom, $udom is the domain, $namespace is the name of the GDBM file
   (encconfig or configuration), and $what is a string containing names of 
   items to retrieve from the db file (each item name is escaped and separated
   from the next item name with an ampersand). The return value is either:
   error: followed by an error message, or a string containing the value (escaped)
   for each item, again separated from the next item with an ampersand.
   
 =back  =back
   
Removed from v.1.3  
changed lines
  Added in v.1.19

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