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

Diff for /loncom/lti/ltiutils.pm between versions 1.9 and 1.17.2.3

version 1.9, 2018/05/15 04:33:17 version 1.17.2.3, 2023/01/23 18:39:46
Line 31  package LONCAPA::ltiutils; Line 31  package LONCAPA::ltiutils;
 use strict;  use strict;
 use Net::OAuth;  use Net::OAuth;
 use Digest::SHA;  use Digest::SHA;
 use UUID::Tiny ':std';  use Digest::MD5 qw(md5_hex);
   use Encode;
   use LWP::UserAgent(); 
 use Apache::lonnet;  use Apache::lonnet;
 use Apache::loncommon;  use Apache::loncommon;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
Line 88  sub check_nonce { Line 90  sub check_nonce {
 #  #
 # LON-CAPA as LTI Consumer  # LON-CAPA as LTI Consumer
 #  #
 # Determine the domain and the courseID of the LON-CAPA course  
 # for which access is needed by a Tool Provider -- either to   
 # retrieve a roster or store the grade for an instance of an   
 # external tool in the course.  
 #  
   
 sub get_loncapa_course {  
     my ($lonhost,$cid,$errors) = @_;  
     return unless (ref($errors) eq 'HASH');  
     my ($cdom,$cnum);  
     if ($cid =~ /^($match_domain)_($match_courseid)$/) {  
         my ($posscdom,$posscnum) = ($1,$2);  
         my $cprimary_id = &Apache::lonnet::domain($posscdom,'primary');  
         if ($cprimary_id eq '') {  
             $errors->{5} = 1;  
             return;  
         } else {  
             my @intdoms;  
             my $internet_names = &Apache::lonnet::get_internet_names($lonhost);  
             if (ref($internet_names) eq 'ARRAY') {  
                 @intdoms = @{$internet_names};  
             }  
             my $cintdom = &Apache::lonnet::internet_dom($cprimary_id);  
             if  (($cintdom ne '') && (grep(/^\Q$cintdom\E$/,@intdoms))) {  
                 $cdom = $posscdom;  
             } else {  
                 $errors->{6} = 1;  
                 return;  
             }  
         }  
         my $chome = &Apache::lonnet::homeserver($posscnum,$posscdom);  
         if ($chome =~ /(con_lost|no_host|no_such_host)/) {  
             $errors->{7} = 1;  
             return;  
         } else {  
             $cnum = $posscnum;  
         }  
     } else {  
         $errors->{8} = 1;  
         return;  
     }  
     return ($cdom,$cnum);  
 }  
   
 #  
 # LON-CAPA as LTI Consumer  
 #  
 # Determine the symb and (optionally) LON-CAPA user for an   
 # instance of an external tool in a course -- either to   
 # to retrieve a roster or store a grade.  
 #  
 # Use the digested symb to lookup the real symb in exttools.db  
 # and the digested userID to lookup the real userID (if needed).  
 # and extract the exttool instance and symb.  
 #  
   
 sub get_tool_instance {  
     my ($cdom,$cnum,$digsymb,$diguser,$errors) = @_;  
     return unless (ref($errors) eq 'HASH');  
     my ($marker,$symb,$uname,$udom);  
     my @keys = ($digsymb);   
     if ($diguser) {  
         push(@keys,$diguser);  
     }  
     my %digesthash = &Apache::lonnet::get('exttools',\@keys,$cdom,$cnum);  
     if ($digsymb) {  
         $symb = $digesthash{$digsymb};  
         if ($symb) {  
             my ($map,$id,$url) = split(/___/,$symb);  
             $marker = (split(m{/},$url))[3];  
             $marker=~s/\D//g;  
         } else {  
             $errors->{9} = 1;  
         }  
     }  
     if ($diguser) {  
         if ($digesthash{$diguser} =~ /^($match_username):($match_domain)$/) {  
             ($uname,$udom) = ($1,$2);  
         } else {  
             $errors->{10} = 1;  
         }  
         return ($marker,$symb,$uname,$udom);  
     } else {  
         return ($marker,$symb);  
     }  
 }  
   
 #  
 # LON-CAPA as LTI Consumer  
 #  
 # Retrieve data needed to validate a request from a Tool Provider  
 # for a roster or to store a grade for an instance of an external   
 # tool in a LON-CAPA course.  
 #  
 # Retrieve the Consumer key and Consumer secret from the domain   
 # configuration or the Tool Provider ID stored in the  
 # exttool_$marker db file and compare the Consumer key with the  
 # one in the POSTed data.  
 #  
 # Side effect is to populate the $toolsettings hashref with the   
 # contents of the .db file (instance of tool in course) and the  
 # $ltitools hashref with the configuration for the tool (at  
 # domain level).  
 #  
   
 sub get_tool_secret {  
     my ($key,$marker,$symb,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;  
     return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') &&  
                    (ref($errors) eq 'HASH'));  
     my ($consumer_secret,$nonce_lifetime);  
     if ($marker) {  
         %{$toolsettings}=&Apache::lonnet::dump('exttool_'.$marker,$cdom,$cnum);  
         if ($toolsettings->{'id'}) {  
             my $idx = $toolsettings->{'id'};  
             my %lti = &Apache::lonnet::get_domain_lti($cdom,'consumer');  
             if (ref($lti{$idx}) eq 'HASH') {  
                 %{$ltitools} = %{$lti{$idx}};  
                 if ($ltitools->{'key'} eq $key) {  
                     $consumer_secret = $ltitools->{'secret'};  
                     $nonce_lifetime = $ltitools->{'lifetime'};  
                 } else {  
                     $errors->{11} = 1;  
                     return;  
                 }  
             } else {  
                 $errors->{12} = 1;  
                 return;  
             }  
         } else {  
             $errors->{13} = 1;  
             return;  
         }  
     } else {  
         $errors->{14};  
         return;  
     }  
     return ($consumer_secret,$nonce_lifetime);  
 }  
   
 #  
 # LON-CAPA as LTI Consumer  
 #  
 # Verify a signed request using the consumer_key and  # Verify a signed request using the consumer_key and
 # secret for the specific LTI Provider.  # secret for the specific LTI Provider.
 #  #
   
 sub verify_request {  sub verify_request {
     my ($params,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$errors) = @_;      my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
     return unless (ref($errors) eq 'HASH');          $authheaders,$errors) = @_;
     my $request = Net::OAuth->request('request token')->from_hash($params,      unless (ref($errors) eq 'HASH') {
                                        request_url => $protocol.'://'.$hostname.$requri,  
                                        request_method => $reqmethod,  
                                        consumer_secret => $consumer_secret,);  
     unless ($request->verify()) {  
         $errors->{15} = 1;          $errors->{15} = 1;
         return;          return;
     }      }
 }      my $request;
       if ($oauthtype eq 'consumer') {
 #          my $oauthreq = Net::OAuth->request('consumer');
 # LON-CAPA as LTI Consumer          $oauthreq->add_required_message_params('body_hash');
 #          $request = $oauthreq->from_authorization_header($authheaders,
 # Verify that an item identifier (either roster request:                                    request_url => $protocol.'://'.$hostname.$requri,
 # ext_ims_lis_memberships_id, or grade store:                                    request_method => $reqmethod,
 # lis_result_sourcedid) has not been tampered with, and                                    consumer_secret => $consumer_secret,);
 # the secret used to create the unique identifier has not  
 # expired.  
 #  
 # Prepending the current secret (if still valid),  
 # or the previous secret (if current one is no longer valid),  
 # to a string composed of the :::-separated components  
 # must generate the result signature in the lis item ID  
 # sent by the Tool Provider.  
 #  
   
 sub verify_lis_item {  
     my ($sigrec,$context,$digsymb,$diguser,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;  
     return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') &&   
                    (ref($errors) eq 'HASH'));  
     my ($has_action, $valid_for);  
     if ($context eq 'grade') {  
         $has_action = $ltitools->{'passback'};  
         $valid_for = $ltitools->{'passbackvalid'}  
     } elsif ($context eq 'roster') {  
         $has_action = $ltitools->{'roster'};  
         $valid_for = $ltitools->{'rostervalid'};  
     }  
     if ($has_action) {  
         my $secret;  
         if (($toolsettings->{$context.'secretdate'} + $valid_for) > time) {  
             $secret = $toolsettings->{$context.'secret'};  
         } else {  
             $secret = $toolsettings->{'old'.$context.'secret'};  
         }  
         if ($secret) {  
             my $expected_sig;  
             if ($context eq 'grade') {  
                 my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;  
                 $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0];   
                 if ($expected_sig eq $sigrec) {  
                     return 1;  
                 } else {  
                     $errors->{17} = 1;  
                 }  
             } elsif ($context eq 'roster') {  
                 my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;  
                 $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0];   
                 if ($expected_sig eq $sigrec) {  
                     return 1;  
                 } else {  
                     $errors->{18} = 1;  
                 }  
             }  
         } else {  
             $errors->{19} = 1;  
         }  
     } else {      } else {
         $errors->{20} = 1;          $request = Net::OAuth->request('request token')->from_hash($params,
                                     request_url => $protocol.'://'.$hostname.$requri,
                                     request_method => $reqmethod,
                                     consumer_secret => $consumer_secret,);
       }
       unless ($request->verify()) {
           $errors->{15} = 1;
           return;
     }      }
     return;  
 }  }
   
 #  #
Line 319  sub verify_lis_item { Line 130  sub verify_lis_item {
 #   # 
   
 sub sign_params {  sub sign_params {
     my ($url,$key,$secret,$sigmethod,$paramsref) = @_;      my ($url,$key,$secret,$paramsref,$sigmethod,$type,$callback,$post) = @_;
     return unless (ref($paramsref) eq 'HASH');      return unless (ref($paramsref) eq 'HASH');
     if ($sigmethod eq '') {      if ($sigmethod eq '') {
         $sigmethod = 'HMAC-SHA1';          $sigmethod = 'HMAC-SHA1';
     }      }
       if ($type eq '') {
           $type = 'request token';
       }
       if ($callback eq '') {
           $callback = 'about:blank',
       }
     srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.      srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.
     my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));      my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));
     my $request = Net::OAuth->request("request token")->new(      my $request = Net::OAuth->request($type)->new(
             consumer_key => $key,              consumer_key => $key,
             consumer_secret => $secret,              consumer_secret => $secret,
             request_url => $url,              request_url => $url,
Line 334  sub sign_params { Line 151  sub sign_params {
             signature_method => $sigmethod,              signature_method => $sigmethod,
             timestamp => time,              timestamp => time,
             nonce => $nonce,              nonce => $nonce,
             callback => 'about:blank',              callback => $callback,
             extra_params => $paramsref,              extra_params => $paramsref,
             version      => '1.0',              version      => '1.0',
             );              );
     $request->sign;      $request->sign();
     return $request->to_hash();      if ($post) {
 }          return $request->to_post_body();
   
 #  
 # LON-CAPA as LTI Consumer  
 #  
 # Generate a signature for a unique identifier (roster request:  
 # ext_ims_lis_memberships_id, or grade store: lis_result_sourcedid)  
 #  
   
 sub get_service_id {  
     my ($secret,$id) = @_;  
     my $sig = Digest::SHA::sha1_hex($secret.':::'.$id);  
     return $sig.':::'.$id;  
 }  
   
 #  
 # LON-CAPA as LTI Consumer  
 #  
 # Generate and store the time-limited secret used to create the  
 # signature in a service request identifier (roster request or  
 # grade store). An existing secret past its expiration date  
 # will be stored as old<service name>secret, and a new secret  
 # <service name>secret will be stored.  
 #   
 # Secrets are specific to service name and to the tool instance   
 # (and are stored in the exttool_$marker db file).  
 # The time period a secret remains valid is determined by the   
 # domain configuration for the specific tool and the service.  
 #   
   
 sub set_service_secret {  
     my ($cdom,$cnum,$marker,$name,$now,$toolsettings,$ltitools) = @_;  
     return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH'));  
     my $warning;  
     my ($needsnew,$oldsecret,$lifetime);  
     if ($name eq 'grade') {  
         $lifetime = $ltitools->{'passbackvalid'}  
     } elsif ($name eq 'roster') {  
         $lifetime = $ltitools->{'rostervalid'};  
     }  
     if ($toolsettings->{$name} eq '') {  
         $needsnew = 1;  
     } elsif (($toolsettings->{$name.'date'} + $lifetime) < $now) {  
         $oldsecret = $toolsettings->{$name.'secret'};  
         $needsnew = 1;  
     }  
     if ($needsnew) {  
         if (&get_tool_lock($cdom,$cnum,$marker,$name,$now) eq 'ok') {  
             my $secret = UUID::Tiny::create_uuid_as_string(UUID_V4);  
             $toolsettings->{$name.'secret'} = $secret;  
             my %secrethash = (  
                            $name.'secret' => $secret,  
                            $name.'secretdate' => $now,  
                           );  
             if ($oldsecret ne '') {  
                 $secrethash{'old'.$name.'secret'} = $oldsecret;  
             }  
             my $putres = &Apache::lonnet::put('exttool_'.$marker,  
                                               \%secrethash,$cdom,$cnum);  
             my $delresult = &release_tool_lock($cdom,$cnum,$marker,$name);  
             if ($delresult ne 'ok') {  
                 $warning = $delresult ;  
             }  
             if ($putres eq 'ok') {  
                 return 'ok';  
             }  
         } else {  
             $warning = 'Could not obtain exclusive lock';  
         }  
     } else {  
         return 'ok';  
     }  
     return;  
 }  
   
 #  
 # LON-CAPA as LTI Consumer  
 #  
 # Add a lock key to exttools.db for the instance of an external tool   
 # when generating and storing a service secret.  
 #  
   
 sub get_tool_lock {  
     my ($cdom,$cnum,$marker,$name,$now) = @_;  
     # get lock for tool for which secret is being set  
     my $lockhash = {  
                      $name."\0".$marker."\0".'lock' => $now.':'.$env{'user.name'}.  
                                                        ':'.$env{'user.domain'},  
                    };  
     my $tries = 0;  
     my $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum);  
   
     while (($gotlock ne 'ok') && $tries <3) {  
         $tries ++;  
         sleep(1);  
         $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum);  
     }  
     return $gotlock;  
 }  
   
 #  
 # LON-CAPA as LTI Consumer  
 #  
 # Remove a lock key from exttools.db for the instance of an external  
 # tool created when generating and storing a service secret.  
 #  
   
 sub release_tool_lock {  
     my ($cdom,$cnum,$marker,$name) = @_;  
     #  remove lock  
     my @del_lock = ($name."\0".$marker."\0".'lock');  
     my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum);  
     if ($dellockoutcome ne 'ok') {  
         return 'Warning: failed to release lock for exttool';  
     } else {      } else {
         return 'ok';          return $request->to_hash();
     }      }
 }  }
   
Line 474  sub release_tool_lock { Line 178  sub release_tool_lock {
 #  #
   
 sub lti_provider_scope {  sub lti_provider_scope {
     my ($tail,$cdom,$cnum) = @_;      my ($tail,$cdom,$cnum,$getunenc) = @_;
     my ($scope,$realuri);      my ($scope,$realuri,$passkey,$unencsymb);
     if ($tail =~ m{^/uploaded/$cdom/$cnum/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) {      if ($tail =~ m{^/?uploaded/$cdom/$cnum/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) {
         my $rest = $1;          my $rest = $1;
         if ($rest eq '') {          if ($rest eq '') {
             $scope = 'map';              $scope = 'map';
             $realuri = $tail;              $realuri = $tail;
         } else {          } else {
             my ($map,$resid,$url) = &Apache::lonnet::decode_symb($tail);              my $symb = $tail;
               $symb =~ s{^/}{};
               my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
             $realuri = &Apache::lonnet::clutter($url);              $realuri = &Apache::lonnet::clutter($url);
             if ($url =~ /\.sequence$/) {              if ($url =~ /\.sequence$/) {
                 $scope = 'map';                  $scope = 'map';
             } else {              } else {
                 $scope = 'resource';                  $scope = 'resource';
                 $realuri .= '?symb='.$tail;                  $realuri .= '?symb='.$symb;
                   $passkey = $symb;
                   if ($getunenc) {
                       $unencsymb = $symb;
                   }
             }              }
         }          }
     } elsif ($tail =~ m{^/res/$match_domain/$match_username/.+\.(?:sequence|page)(|___\d+___.+)$}) {      } elsif ($tail =~ m{^/?res/$match_domain/$match_username/.+\.(?:sequence|page)(|___\d+___.+)$}) {
         my $rest = $1;          my $rest = $1;
         if ($rest eq '') {          if ($rest eq '') {
             $scope = 'map';              $scope = 'map';
             $realuri = $tail;              $realuri = $tail;
         } else {          } else {
             my ($map,$resid,$url) = &Apache::lonnet::decode_symb($tail);              my $symb = $tail;
               $symb =~ s{^/?res/}{};
               my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
             $realuri = &Apache::lonnet::clutter($url);              $realuri = &Apache::lonnet::clutter($url);
             if ($url =~ /\.sequence$/) {              if ($url =~ /\.sequence$/) {
                 $scope = 'map';                  $scope = 'map';
             } else {              } else {
                 $scope = 'resource';                  $scope = 'resource';
                 $realuri .= '?symb='.$tail;                  $realuri .= '?symb='.$symb;
                   $passkey = $symb;
                   if ($getunenc) {
                       $unencsymb = $symb;
                   }
             }              }
         }          }
     } elsif ($tail =~ m{^/tiny/$cdom/(\w+)$}) {      } elsif ($tail =~ m{^/tiny/$cdom/(\w+)$}) {
Line 528  sub lti_provider_scope { Line 244  sub lti_provider_scope {
             } else {              } else {
                 $scope = 'resource';                  $scope = 'resource';
             }              }
               $passkey = $symb;
             if ((&Apache::lonnet::EXT('resource.0.encrypturl',$symb) =~ /^yes$/i) &&              if ((&Apache::lonnet::EXT('resource.0.encrypturl',$symb) =~ /^yes$/i) &&
                 (!$env{'request.role.adv'})) {                  (!$env{'request.role.adv'})) {
                 $realuri = &Apache::lonenc::encrypted(&Apache::lonnet::clutter($url));                  $realuri = &Apache::lonenc::encrypted(&Apache::lonnet::clutter($url));
Line 540  sub lti_provider_scope { Line 257  sub lti_provider_scope {
                     $realuri .= '?symb='.$symb;                      $realuri .= '?symb='.$symb;
                 }                  }
             }              }
               if ($getunenc) {
                   $unencsymb = $symb;
               }
         }          }
     } elsif ($tail =~ m{^/$cdom/$cnum$}) {      } elsif (($tail =~ m{^/$cdom/$cnum$}) || ($tail eq '')) {
         $scope = 'course';          $scope = 'course';
         $realuri = '/adm/navmaps';          $realuri = '/adm/navmaps';
           $passkey = '';
       }
       if ($scope eq 'map') {
           $passkey = $realuri;
       }
       if (wantarray) {
           return ($scope,$realuri,$unencsymb);
       } else {
           return $passkey;
       }
   }
   
   sub setup_logout_callback {
       my ($uname,$udom,$server,$ckey,$secret,$service_url,$idsdir,$protocol,$hostname) = @_;
       if ($service_url =~ m{^https?://[^/]+/}) {
           my $digest_user = &Encode::decode('UTF-8',$uname.':'.$udom);
           my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$));
           if ((-d $idsdir) && (open(my $fh,'>',"$idsdir/$loginfile"))) {
               print $fh "$uname,$udom,$server\n";
               close($fh);
               my $callback = 'http://'.$hostname.'/adm/service/logout/'.$loginfile;
               my %ltiparams = (
                   callback   => $callback,
               );
               my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams,
                                       '','','',1);
   
               my $ua=new LWP::UserAgent;
               $ua->timeout(10);
               my $request=new HTTP::Request('POST',$service_url);
               $request->content($post);
               my $response=$ua->request($request); 
           }
       }
       return;
   }
   
   #
   # LON-CAPA as LTI Provider
   #
   # Create a new user in LON-CAPA. If the domain's configuration 
   # includes rules for format of "official" usernames, those rules
   # will apply when determining if a user is to be created.  In
   # additional if institutional user information is available that
   # will be used when creating a new user account.
   #
   
   sub create_user {
       my ($ltiref,$uname,$udom,$domdesc,$data,$alerts,$rulematch,$inst_results,
           $curr_rules,$got_rules) = @_;
       return unless (ref($ltiref) eq 'HASH');
       my $checkhash = { "$uname:$udom" => { 'newuser' => 1, }, };
       my $checks = { 'username' => 1, };
       my ($lcauth,$lcauthparm);
       &Apache::loncommon::user_rule_check($checkhash,$checks,$alerts,$rulematch,
                                           $inst_results,$curr_rules,$got_rules);
       my ($userchkmsg,$lcauth,$lcauthparm);
       my $allowed = 1;
       if (ref($alerts->{'username'}) eq 'HASH') {
            if (ref($alerts->{'username'}{$udom}) eq 'HASH') {
                if ($alerts->{'username'}{$udom}{$uname}) {
                    if (ref($curr_rules->{$udom}) eq 'HASH') {
                        $userchkmsg =
                            &Apache::loncommon::instrule_disallow_msg('username',$domdesc,1).
                            &Apache::loncommon::user_rule_formats($udom,$domdesc,
                                                                  $curr_rules->{$udom}{'username'},
                                                                  'username');
                    }
                    $allowed = 0;
                }
            }
       }
       if ($allowed) {
           if (ref($rulematch->{$uname.':'.$udom}) eq 'HASH') {
               my $matchedrule = $rulematch->{$uname.':'.$udom}{'username'};
               my ($rules,$ruleorder) =
                   &Apache::lonnet::inst_userrules($udom,'username');
               if (ref($rules) eq 'HASH') {
                   if (ref($rules->{$matchedrule}) eq 'HASH') {
                       $lcauth = $rules->{$matchedrule}{'authtype'};
                       $lcauthparm = $rules->{$matchedrule}{'authparm'};
                   }
               }
           }
           if ($lcauth eq '') {
               $lcauth = $ltiref->{'lcauth'};
               if ($lcauth eq 'internal') {
                   $lcauthparm = &create_passwd();
               } else {
                   $lcauthparm = $ltiref->{'lcauthparm'};
               }
           }
       } else {
           return 'notallowed';
       }
       my @userinfo = ('firstname','middlename','lastname','generation','permanentemail','id');
       my (%useinstdata,%info);
       if (ref($ltiref->{'instdata'}) eq 'ARRAY') {
           map { $useinstdata{$_} = 1; } @{$ltiref->{'instdata'}};
       }
       foreach my $item (@userinfo) {
           if (($useinstdata{$item}) && (ref($inst_results->{$uname.':'.$udom}) eq 'HASH') &&
               ($inst_results->{$uname.':'.$udom}{$item} ne '')) {
               $info{$item} = $inst_results->{$uname.':'.$udom}{$item};
           } else {
               if ($item eq 'permanentemail') {
                   if ($data->{'permanentemail'} =~/^[^\@]+\@[^@]+$/) {
                       $info{$item} = $data->{'permanentemail'};
                   }
               } elsif (($item eq 'firstname') || ($item eq 'lastname')) {
                   $info{$item} = $data->{$item};
               }
           }
       }
       if (($info{'middlename'} eq '') && ($data->{'fullname'} ne '')) {
           unless ($useinstdata{'middlename'}) {
               my $fullname = $data->{'fullname'};
               if ($info{'firstname'}) {
                   $fullname =~ s/^\s*\Q$info{'firstname'}\E\s*//i;
               }
               if ($info{'lastname'}) {
                   $fullname =~ s/\s*\Q$info{'lastname'}\E\s*$//i;
               }
               if ($fullname ne '') {
                   $fullname =~ s/^\s+|\s+$//g;
                   if ($fullname ne '') {
                       $info{'middlename'} = $fullname;
                   }
               }
           }
       }
       if (ref($inst_results->{$uname.':'.$udom}{'inststatus'}) eq 'ARRAY') {
           my @inststatuses = @{$inst_results->{$uname.':'.$udom}{'inststatus'}};
           $info{'inststatus'} = join(':',map { &escape($_); } @inststatuses);
       }
       my $result =
           &Apache::lonnet::modifyuser($udom,$uname,$info{'id'},
                                       $lcauth,$lcauthparm,$info{'firstname'},
                                       $info{'middlename'},$info{'lastname'},
                                       $info{'generation'},undef,undef,
                                       $info{'permanentemail'},$info{'inststatus'});
       return $result;
   }
   
   #
   # LON-CAPA as LTI Provider
   #
   # Create a password for a new user if the authentication
   # type to assign to new users created following LTI launch is
   # to be LON-CAPA "internal".
   #
   
   sub create_passwd {
       my $passwd = '';
       srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.
       my @letts = ("a".."z");
       for (my $i=0; $i<8; $i++) {
           my $lettnum = int(rand(2));
           my $item = '';
           if ($lettnum) {
               $item = $letts[int(rand(26))];
               my $uppercase = int(rand(2));
               if ($uppercase) {
                   $item =~ tr/a-z/A-Z/;
               }
           } else {
               $item = int(rand(10));
           }
           $passwd .= $item;
       }
       return ($passwd);
   }
   
   #
   # LON-CAPA as LTI Provider
   #
   # Enroll a user in a LON-CAPA course, with the specified role and (optional)
   # section.  If this is a self-enroll case, i.e., a user launched the LTI tool
   # in the Consumer, user privs will be added to the user's environment for
   # the new role.
   #
   # If this is a self-enroll case, a Course Coordinator role will only be assigned 
   # if the current user is also the course owner.
   #
   
   sub enrolluser {
       my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end,$selfenroll) = @_;
       my $enrollresult;
       my $area = "/$cdom/$cnum";
       if (($role ne 'cc') && ($role ne 'co') && ($sec ne '')) {
           $area .= '/'.$sec;
       }
       my $spec = $role.'.'.$area;
       my $instcid;
       if ($role eq 'st') {
           $enrollresult =
               &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,
                                                          undef,undef,$sec,$end,$start,
                                                          'ltienroll',undef,$cdom.'_'.$cnum,
                                                          $selfenroll,'ltienroll','',$instcid);
       } elsif ($role =~ /^(cc|in|ta|ep)$/) {
           $enrollresult =
               &Apache::lonnet::assignrole($udom,$uname,$area,$role,$end,$start,
                                           undef,$selfenroll,'ltienroll');
       }
       if ($enrollresult eq 'ok') {
           if ($selfenroll) {
               my (%userroles,%newrole,%newgroups);
               &Apache::lonnet::standard_roleprivs(\%newrole,$role,$cdom,$spec,$cnum,
                                                   $area);
               &Apache::lonnet::set_userprivs(\%userroles,\%newrole,\%newgroups);
               $userroles{'user.role.'.$spec} = $start.'.'.$end;
               &Apache::lonnet::appenv(\%userroles,[$role,'cm']);
           }
       }
       return $enrollresult;
   }
   
   #
   # LON-CAPA as LTI Provider
   #
   # Gather a list of available LON-CAPA roles derived
   # from a comma separated list of LTI roles.
   #
   # Which LON-CAPA roles are assignable by the current user
   # and how LTI roles map to LON-CAPA roles (as defined in
   # the domain configuration for the specific Consumer) are 
   # factored in when compiling the list of available roles.
   #
   # Inputs: 3
   #  $rolestr - comma separated list of LTI roles.
   #  $allowedroles - reference to array of assignable LC roles
   #  $maproles - ref to HASH of mapping of LTI roles to LC roles
   #
   # Outputs: 2
   # (a) reference to array of available LC roles.
   # (b) reference to array of LTI roles.
   #
   
   sub get_lc_roles {
       my ($rolestr,$allowedroles,$maproles) = @_;
       my (@ltiroles,@lcroles);
       my @ltiroleorder = ('Instructor','TeachingAssistant','Mentor','Learner');
       if ($rolestr =~ /,/) {
           my @possltiroles = split(/\s*,\s*/,$rolestr);
           foreach my $ltirole (@ltiroleorder) {
               if (grep(/^\Q$ltirole\E$/,@possltiroles)) {
                   push(@ltiroles,$ltirole);
               }
           }
       } else {
           my $singlerole = $rolestr;
           $singlerole =~ s/^\s|\s+$//g;
           if ($singlerole ne '') {
               if (grep(/^\Q$singlerole\E$/,@ltiroleorder)) {
                   @ltiroles = ($singlerole);
               }
           }
       }
       if (@ltiroles) {
           my %possroles;
           map { $possroles{$maproles->{$_}} = 1; } @ltiroles;
           if (keys(%possroles) > 0) {
               if (ref($allowedroles) eq 'ARRAY') {
                   foreach my $item (@{$allowedroles}) {
                       if (($item eq 'co') || ($item eq 'cc')) {
                           if ($possroles{'cc'}) {
                               push(@lcroles,$item);
                           }
                       } elsif ($possroles{$item}) {
                           push(@lcroles,$item);
                       }
                   }
               }
           }
     }      }
     return ($scope,$realuri);      return (\@lcroles,\@ltiroles);
 }  }
   
 1;  1;
Removed from v.1.9  
changed lines
  Added in v.1.17.2.3

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