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

Diff for /loncom/Lond.pm between versions 1.8.2.3.2.5 and 1.9

version 1.8.2.3.2.5, 2024/08/18 01:37:26 version 1.9, 2016/07/25 19:49:45
Line 37  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 Net::OAuth;  use Crypt::OpenSSL::X509;
 use Crypt::CBC;  
 use Digest::SHA;  
 use Digest::MD5 qw(md5_hex);  
   
 sub dump_with_regexp {  sub dump_with_regexp {
     my ( $tail, $clientversion ) = @_;      my ( $tail, $clientversion ) = @_;
Line 61  sub dump_with_regexp { Line 59  sub dump_with_regexp {
         }          }
     }      }
   
 #  
 # If dump is for file_permissions.db from a pre-2.12 server and  
 # $uname:$udom is not a course, determine if value of portaccess  
 # in effect for $uname:$udom allows portfolio files to be shared.  
 # If sharing is not allowed, records returned for accesscontrol  
 # are restricted to those based on ip (i.e., for externalresponse).  
 #  
 # Note: for 2.12 or later session-hosting server, determination  
 # of portaccess value in effect occurs client-side.  
 #  
     my ($check_portaccess,$access,$now,$major,$minor,%by_ip);  
     if ($namespace eq 'file_permissions') {  
         if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {  
             $major = $1;  
             $minor = $2;  
         }  
         unless ((($major > 2) || (($major == 2) && ($minor > 11))) ||  
                 &is_course($udom,$uname)) {  
             $check_portaccess = 1;  
             $access = &portfolio_is_shareable($udom,$uname);  
         }  
         $now = time;  
     }  
   
     my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or       my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or 
         return "error: ".($!+0)." tie(GDBM) Failed while attempting dump";          return "error: ".($!+0)." tie(GDBM) Failed while attempting dump";
   
Line 98  sub dump_with_regexp { Line 72  sub dump_with_regexp {
 #   # 
     my $skipcheck;      my $skipcheck;
     my @ids = &Apache::lonnet::current_machine_ids();      my @ids = &Apache::lonnet::current_machine_ids();
     my %homecourses;      my (%homecourses, $major, $minor, $now);
 #   # 
 # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA     # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA   
 # version on the server which requested the data.   # version on the server which requested the data. 
Line 136  sub dump_with_regexp { Line 110  sub dump_with_regexp {
                     }                      }
                 }                  }
             }              }
             if ($namespace eq 'file_permissions') {  
                 if ($check_portaccess) {  
                     unless ($access) {  
                         my $unesckey = &unescape($key);  
                         if ($unesckey =~ m{\0((\d+)_\d+_\d+:([a-z]+)_(\d+)_(\d+))$}) {  
                             my ($acl,$timestamp,$scope,$end,$start) = ($1,$2,$3,$4);  
                             if ($scope eq 'ip') {  
                                 unless (($start > $now) &&  
                                         ($end && $end<$now)) {  
                                     my ($path) = split(/\0/,$unesckey);  
                                     push(@{$by_ip{$path}},{$acl => $timestamp});  
                                 }  
                             }  
                             next;  
                         } elsif ($unesckey =~ m{\0accesscontrol$}) {  
                             next;  
                         }  
                     }  
                 }  
             }  
         if ($regexp eq '.') {          if ($regexp eq '.') {
             $count++;              $count++;
             if (defined($range) && $count >= $end)   { last; }              if (defined($range) && $count >= $end)   { last; }
Line 171  sub dump_with_regexp { Line 125  sub dump_with_regexp {
             }              }
         }          }
     }      }
     if (($namespace eq 'file_permissions') && ($check_portaccess) && (!$access)) {  
         if (keys(%by_ip)) {  
             my %accesscontrol;  
             foreach my $path (keys(%by_ip)) {  
                 if (ref($by_ip{$path}) eq 'ARRAY') {  
                     foreach my $item (@{$by_ip{$path}}) {  
                         if (ref($item) eq 'HASH') {  
                             my ($acl,$timestamp) = each(%$item);  
                             my $key = &escape("$path\0$acl");  
                             my $value = $hashref->{$key};  
                             $qresult.= "$key=$value&";  
                             $accesscontrol{"$path\0accesscontrol"}{$acl} = $timestamp;  
                         }  
                     }  
                 }  
             }  
             if (keys(%accesscontrol)) {  
                 while (my ($key,$value) = each(%accesscontrol)) {  
                     $qresult.= &escape($key).'='.&Apache::lonnet::freeze_escape($value).'&';  
                 }  
             }  
         }  
     }  
     &untie_user_hash($hashref) or       &untie_user_hash($hashref) or 
         return "error: ".($!+0)." untie(GDBM) Failed while attempting dump";          return "error: ".($!+0)." untie(GDBM) Failed while attempting dump";
 #  #
Line 308  sub check_homecourses { Line 240  sub check_homecourses {
                     }                      }
                 }                  }
                 unless (&untie_domain_hash($hashref)) {                  unless (&untie_domain_hash($hashref)) {
                     &Apache::lonnet::logthis("Failed to untie tied hash for nohist_courseids.db for $domain");                      &logthis("Failed to untie tied hash for nohist_courseids.db for $domain");
                 }                  }
             } else {              } else {
                 &Apache::lonnet::logthis("Failed to tie hash for nohist_courseids.db for $domain");                  &logthis("Failed to tie hash for nohist_courseids.db for $domain");
             }              }
         }          }
         foreach my $hashid (keys(%recent)) {          foreach my $hashid (keys(%recent)) {
Line 383  sub get_courseinfo_hash { Line 315  sub get_courseinfo_hash {
     };      };
     if ($@) {      if ($@) {
         if ($@ eq "timeout\n") {          if ($@ eq "timeout\n") {
             &Apache::lonnet::logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");              &logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
         } else {          } else {
             &Apache::lonnet::logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");              &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 396  sub get_courseinfo_hash { Line 328  sub get_courseinfo_hash {
     return;      return;
 }  }
   
 sub portfolio_is_shareable {  
     my ($udom,$uname) = @_;  
     my $check_portaccess = 1;  
     my ($userportaccess,$inststatus,$access);  
     my $hashref = &tie_user_hash($udom, $uname, 'environment', &GDBM_READER());  
     if (ref($hashref) eq 'HASH') {  
         my $accesskey = &escape('tools.portaccess');  
         $userportaccess = $hashref->{$accesskey};  
         $inststatus = $hashref->{'inststatus'};  
         &untie_user_hash($hashref);  
     }  
     if ($userportaccess ne '') {  
         $access = $userportaccess;  
     } else {  
         my %domdefs = &Apache::lonnet::get_domain_defaults($udom);  
         if (ref($domdefs{'portaccess'}) eq 'HASH') {  
             if (($domdefs{'portaccess'}{'_LC_adv'} ne '') &&  
                 (&Apache::lonnet::is_advanced_user($udom,$uname))) {  
                 if ($domdefs{'portaccess'}{'_LC_adv'}) {  
                     $access = 1;  
                 } else {  
                     $access = 0;  
                 }  
             } elsif ($inststatus ne '') {  
                 my ($hasaccess,$hasnoaccess);  
                 foreach my $affiliation (split(/:/,$inststatus)) {  
                     if ($domdefs{'portaccess'}{$affiliation} ne '') {  
                         if ($domdefs{'portaccess'}{$affiliation}) {  
                             $hasaccess = 1;  
                         } else {  
                             $hasnoaccess = 1;  
                         }  
                     }  
                 }  
                 if ($hasaccess || $hasnoaccess) {  
                     if ($hasaccess) {  
                         $access = 1;  
                     } elsif ($hasnoaccess) {  
                         $access = 0;  
                     }  
                 }  
             } else {  
                 if ($domdefs{'portaccess'}{'default'} ne '') {  
                     if ($domdefs{'portaccess'}{'default'}) {  
                         $access = 1;  
                     } elsif ($domdefs{'portaccess'}{'default'} == 0) {  
                         $access = 0;  
                     }  
                 }  
             }  
         } else {  
             $access = 1;  
         }  
     }  
     return $access;  
 }  
   
 sub dump_course_id_handler {  sub dump_course_id_handler {
     my ($tail) = @_;      my ($tail) = @_;
   
Line 908  sub dump_profile_database { Line 783  sub dump_profile_database {
     return $qresult;      return $qresult;
 }  }
   
 sub is_course {  sub server_certs {
     my ($cdom,$cnum) = @_;      my ($perlvar) = @_;
       my %pemfiles = (
     return unless (($cdom =~ /^$LONCAPA::match_domain$/) &&                       key      => 'lonnetPrivateKey',
                    ($cnum =~ /^$LONCAPA::match_courseid$/));                       host     => 'lonnetCertificate',
     my $hashid = $cdom.':'.$cnum;                       hostname => 'lonnetHostnameCertificate',
     my ($iscourse,$cached) =                       ca       => 'lonnetCertificateAuthority',
         &Apache::lonnet::is_cached_new('iscourse',$hashid);                     );
     unless (defined($cached)) {      my (%md5hash,%info);
         my $hashref =      if (ref($perlvar) eq 'HASH') {
             &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());          my $certsdir = $perlvar->{'lonCertificateDirectory'};
         if (ref($hashref) eq 'HASH') {          if (-d $certsdir) {
             my $esc_key = &escape($cdom.'_'.$cnum);              foreach my $key (keys(%pemfiles)) {
             if (exists($hashref->{$esc_key})) {                  if ($perlvar->{$pemfiles{$key}}) {
                 $iscourse = 1;                      my $file = $certsdir.'/'.$perlvar->{$pemfiles{$key}};
             } else {                      if (-e $file) {
                 $iscourse = 0;                          if ($key eq 'key') {
             }                              if (open(PIPE,"openssl rsa -noout -in $file -check |")) {
             &Apache::lonnet::do_cache_new('iscourse',$hashid,$iscourse,3600);                                  my $check = <PIPE>;
             unless (&untie_domain_hash($hashref)) {                                  close(PIPE);
                 &Apache::lonnet::logthis("Failed to untie tied hash for nohist_courseids.db for $cdom");                                  chomp($check);
             }                                  $info{$key}{'status'} = $check;
         } else {                              }
             &Apache::lonnet::logthis("Failed to tie hash for nohist_courseids.db for $cdom");                              if (open(PIPE,"openssl rsa -noout -modulus -in $file | openssl md5 |")) {
         }                                  $md5hash{$key} = <PIPE>;
     }                                  close(PIPE);
     return $iscourse;                              }
 }                          } else {
                               if ($key eq 'ca') {
 sub get_dom {                                  if (open(PIPE,"openssl verify -CAfile $file $file |")) {
     my ($userinput) = @_;                                      my $check = <PIPE>;
     my ($cmd,$udom,$namespace,$what) =split(/:/,$userinput,4);                                      close(PIPE);
     my $hashref = &tie_domain_hash($udom,$namespace,&GDBM_READER()) or                                      chomp($check);
         return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd";                                      if ($check eq "$file: OK") {
     my $qresult='';                                          $info{$key}{'status'} = 'ok';
     if (ref($hashref)) {                                      } else {
         chomp($what);                                          $check =~ s/^\Q$file\E\:?\s*//;
         my @queries=split(/\&/,$what);                                          $info{$key}{'status'} = $check;
         for (my $i=0;$i<=$#queries;$i++) {                                      }
             $qresult.="$hashref->{$queries[$i]}&";                                  }
         }                              } else {
         $qresult=~s/\&$//;                                  if (open(PIPE,"openssl x509 -noout -modulus -in $file | openssl md5 |")) {
     }                                      $md5hash{$key} = <PIPE>;
     &untie_user_hash($hashref) or                                      close(PIPE);
         return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd";                                  }
     return $qresult;                              }
 }                              my $x509 = Crypt::OpenSSL::X509->new_from_file($file);
                               my @items = split(/,\s+/,$x509->subject());
 sub store_dom {                              foreach my $item (@items) {
     my ($userinput) = @_;                                  my ($name,$value) = split(/=/,$item);
     my ($cmd,$dom,$namespace,$rid,$what) =split(/:/,$userinput);                                  if ($name eq 'CN') {
     my $hashref  = &tie_domain_hash($dom,$namespace,&GDBM_WRCREAT(),"S","$rid:$what") or                                      $info{$key}{'cn'} = $value;
         return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd";                                  }
     $hashref->{"version:$rid"}++;                              }
     my $version=$hashref->{"version:$rid"};                              $info{$key}{'start'} = $x509->notBefore();
     my $allkeys='';                              $info{$key}{'end'} = $x509->notAfter();
     my @pairs=split(/\&/,$what);                              $info{$key}{'alg'} = $x509->sig_alg_name();
     foreach my $pair (@pairs) {                              $info{$key}{'size'} = $x509->bit_length();
         my ($key,$value)=split(/=/,$pair);                              $info{$key}{'email'} = $x509->email();
         $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));  
   
     my %courselti = &Apache::lonnet::get_course_lti($cnum,$cdom,'provider');  
   
     if (ref($crslti_by_key{$consumer_key}) eq 'ARRAY') {  
         foreach my $id (@{$crslti_by_key{$consumer_key}}) {  
             my $secret = $crslti{$id}{'secret'};  
             if (ref($courselti{$id}) eq 'HASH') {  
                 if ((exists($courselti{$id}{'cipher'})) &&  
                     ($courselti{$id}{'cipher'} =~ /^\d+$/)) {  
                     my $keynum = $courselti{$id}{'cipher'};  
                     my $privkey = &get_dom("getdom:$cdom:private:$keynum:lti:key");  
                     if ($privkey ne '') {  
                         my $cipher = new Crypt::CBC($privkey);  
                         $secret = $cipher->decrypt_hex($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 ($name,$cachename);  
     if ($context eq 'linkprot') {  
         $name = $context;  
     } else {  
         $name = 'lti';  
         if ($context eq '') {  
             $context = 'provider';  
         }  
     }  
     $cachename = $name.'enc';  
     my %ltienc;  
     my ($encresult,$enccached)=&Apache::lonnet::is_cached_new($cachename,$dom);  
     if (defined($enccached)) {  
         if (ref($encresult) eq 'HASH') {  
             %ltienc = %{$encresult};  
         }  
     } else {  
         my $reply = &get_dom("getdom:$dom:encconfig:$name");  
         my $ltiencref = &Apache::lonnet::thaw_unescape($reply);  
         if (ref($ltiencref) eq 'HASH') {  
             %ltienc = %{$ltiencref};  
         }  
         my $cachetime = 24*60*60;  
         &Apache::lonnet::do_cache_new($cachename,$dom,\%ltienc,$cachetime);  
     }  
   
     return if (!keys(%ltienc));  
   
     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 '')) {  
                 push(@{$lti_by_key{$key}},$id);  
             }  
         }  
     }  
     return if (!keys(%lti_by_key));  
   
     my %lti = &Apache::lonnet::get_domain_lti($dom,$context);  
   
     if (ref($lti_by_key{$consumer_key}) eq 'ARRAY') {  
         foreach my $id (@{$lti_by_key{$consumer_key}}) {  
             my $secret = $ltienc{$id}{'secret'};  
             if (ref($lti{$id}) eq 'HASH') {  
                 if ((exists($lti{$id}{'cipher'})) &&  
                     ($lti{$id}{'cipher'} =~ /^\d+$/)) {  
                     my $keynum = $lti{$id}{'cipher'};  
                     my $privkey = &get_dom("getdom:$dom:private:$keynum:lti:key");  
                     if ($privkey ne '') {  
                         my $cipher = new Crypt::CBC($privkey);  
                         $secret = $cipher->decrypt_hex($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 sign_lti_payload {  
     my ($cdom,$cnum,$crsdef,$type,$context,$url,$idx,$keynum,$loncaparev,$paramsref,$inforef) = @_;  
     return unless (ref($paramsref) eq 'HASH');  
     my ($sigmethod,$callback,$reqtype,$reqmethod,$respfmt,$bodyhash);  
     if (ref($inforef) eq 'HASH') {  
         if (exists($inforef->{'method'})) {  
             $sigmethod = $inforef->{'method'};  
         }  
         if (exists($inforef->{'cb'})) {  
             $callback = $inforef->{'cb'};  
         }  
         if (exists($inforef->{'reqtype'})) {  
             $reqtype = $inforef->{'reqtype'};  
         }          }
         if (exists($inforef->{'reqmethod'})) {  
             $reqmethod = $inforef->{'reqmethod'};  
         }  
         if (exists($inforef->{'body_hash'})) {  
             $bodyhash = $inforef->{'body_hash'};  
         }  
         if (exists($inforef->{'respfmt'})) {  
             $respfmt = $inforef->{'respfmt'};  
         }  
     }  
     my ($key,$secret) = &get_lti_credentials($cdom,$cnum,$crsdef,$type,$idx,$keynum,$loncaparev);  
     return if (($key eq '') || ($secret eq ''));  
     if ($sigmethod eq '') {  
         $sigmethod = 'HMAC-SHA1';  
     }  
     if ($callback eq '') {  
         $callback = 'about:blank',  
     }  
     if ($reqtype eq '') {  
         $reqtype = 'request token';  
     }  
     if ($reqmethod eq '') {  
         $reqmethod = 'POST';  
     }  
     srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.  
     my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));  
     my $request;  
     if (($context eq 'grade') && ($reqtype eq 'consumer') && ($bodyhash ne '')) {  
         $request = Net::OAuth->request($reqtype)->new(  
                            consumer_key => $key,  
                            consumer_secret => $secret,  
                            request_url => $url,  
                            request_method => $reqmethod,  
                            signature_method => $sigmethod,  
                            timestamp => time(),  
                            nonce => $nonce,  
                            body_hash => $bodyhash,  
         );  
         $request->add_required_message_params('body_hash');  
     } else {  
         $request = Net::OAuth->request($reqtype)->new(  
             consumer_key => $key,  
             consumer_secret => $secret,  
             request_url => $url,  
             request_method => 'POST',  
             signature_method => $sigmethod,  
             timestamp => time,  
             nonce => $nonce,  
             callback => $callback,  
             extra_params => $paramsref,  
             version      => '1.0',  
             );  
     }  
     $request->sign();  
     if ($respfmt eq 'to_post_body') {  
         return $request->to_post_body();  
     } elsif ($respfmt eq 'to_authorization_header') {  
         return $request->to_authorization_header();  
     } else {  
         return $request->to_hash();  
     }  
 }  
   
 sub get_lti_credentials {  
     my ($cdom,$cnum,$crsdef,$type,$idx,$keynum,$loncaparev) = @_;  
     my ($dbname,$name,$cachename,$hashid,$key,$secret,%ltienc);  
     if ($crsdef) {  
         $hashid = $cdom.'_'.$cnum;  
     } else {  
         $hashid = $cdom;  
     }      }
     if ($type eq 'tools') {      foreach my $key ('host','hostname') {
         if ($crsdef) {          if ($md5hash{$key}) {
             $dbname = 'nohist_toolsenc';              if ($md5hash{$key} eq $md5hash{'key'}) {
             $cachename = 'crsltitoolsenc';                  $info{$key}{'status'} = 'ok';
         } else {  
             $name = 'ltitools';  
             $dbname = 'encconfig';  
             $cachename = 'ltitoolsenc';  
         }  
     } elsif ($type eq 'linkprot') {  
         if ($crsdef) {  
             $dbname = 'nohist_ltienc';  
             $cachename = 'courseltienc';  
         } else {  
             $name = 'linkprot';  
             $dbname = 'encconfig';  
             $cachename = 'linkprotenc';  
         }  
     } elsif ($type eq 'lti') {  
         $name = 'lti';  
         $dbname = 'encconfig';  
         $cachename = 'ltienc';  
     }  
     my ($encresult,$enccached)=&Apache::lonnet::is_cached_new($cachename,$hashid);  
     if (defined($enccached)) {  
         if (ref($encresult) eq 'HASH') {  
             %ltienc = %{$encresult};  
         }  
     } else {  
         if ($crsdef) {  
             my $reply = &dump_with_regexp(join(":",($cdom,$cnum,$dbname,'','')),$loncaparev);  
             %ltienc = %{&Apache::lonnet::unserialize($reply)};  
         } else {  
             my $reply = &get_dom("getdom:$cdom:$dbname:$name");  
             my $encref = &Apache::lonnet::thaw_unescape($reply);  
             if (ref($encref) eq 'HASH') {  
                 %ltienc = %{$encref};  
             }              }
         }          }
         my $cachetime = 24*60*60;  
         &Apache::lonnet::do_cache_new($cachename,$hashid,\%ltienc,$cachetime);  
     }      }
     if (!keys(%ltienc)) {      my $result;
          return ();      foreach my $key (keys(%info)) {
     } elsif (exists($ltienc{$idx})) {          $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($info{$key}).'&';
         if (ref($ltienc{$idx}) eq 'HASH') {  
             if (exists($ltienc{$idx}{'key'})) {  
                 $key = $ltienc{$idx}{'key'};  
             }  
             if (exists($ltienc{$idx}{'secret'})) {  
                 $secret = $ltienc{$idx}{'secret'};  
                 if ($keynum =~ /^\d+$/) {  
                     my $privhost;  
                     my $privname = 'ltitools';  
                     if (($type eq 'lti') || ($type eq 'linkprot')) {  
                         $privname = 'lti';  
                     }  
                     if ($crsdef) {  
                         my $primary = &Apache::lonnet::domain($cdom,'primary');  
                         my @ids = &Apache::lonnet::current_machine_ids();  
                         unless (grep(/^\Q$primary\E$/,@ids)) {  
                             $privhost = $primary;  
                             my ($result,$plainsecret) = &decrypt_secret($privhost,$secret,$keynum,$privname);  
                             if ($result eq 'ok') {  
                                 $secret = $plainsecret;  
                             } else {  
                                 undef($secret);  
                             }  
                         }  
                     }  
                     unless ($privhost) {  
                         my $privkey = &get_dom("getdom:$cdom:private:$keynum:$privname:key");  
                         if (($privkey ne '') && ($secret ne '')) {  
                             my $cipher = new Crypt::CBC($privkey);  
                             $secret = $cipher->decrypt_hex($secret);  
                         } else {  
                             undef($secret);  
                         }  
                     }  
                 }  
             }  
         }  
     }      }
     return ($key,$secret);      $result =~ s/\&$//;
 }      return $result;
   
 sub decrypt_secret {  
     my ($privhost,$secret,$keynum,$type) = @_;  
     return;  
 }  }
   
 1;  1;
Line 1466  courseID -- for the course for which the Line 985  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.8.2.3.2.5  
changed lines
  Added in v.1.9

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