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

Diff for /loncom/lti/ltiutils.pm between versions 1.13 and 1.17.2.1

version 1.13, 2018/08/12 02:24:42 version 1.17.2.1, 2022/01/03 18:35:27
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 Apache::lonnet;  use Apache::lonnet;
 use Apache::loncommon;  use Apache::loncommon;
 use Apache::loncoursedata;  
 use Apache::lonuserutils;  
 use Apache::lonenc();  
 use Apache::longroup();  
 use Apache::lonlocal;  
 use Math::Round();  
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
   
 #  #
Line 94  sub check_nonce { Line 87  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 325  sub verify_lis_item { Line 127  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 340  sub sign_params { Line 148  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 578  sub lti_provider_scope { Line 273  sub lti_provider_scope {
     }      }
 }  }
   
 #  sub setup_logout_callback {
 # LON-CAPA as LTI Provider      my ($uname,$udom,$server,$ckey,$secret,$service_url,$idsdir,$protocol,$hostname) = @_;
 #      if ($service_url =~ m{^https?://[^/]+/}) {
 # Obtain a list of course personnel and students from          my $digest_user = &Encode::decode_utf8($uname.':'.$udom);
 # the LTI Consumer which launched this instance.          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";
 sub get_roster {              close($fh);
     my ($id,$url,$ckey,$secret) = @_;              my $callback = 'http://'.$hostname.'/adm/service/logout/'.$loginfile;
     my %ltiparams = (              my %ltiparams = (
         lti_version                => 'LTI-1p0',                  callback   => $callback,
         lti_message_type           => 'basic-lis-readmembershipsforcontext',  
         ext_ims_lis_memberships_id => $id,  
     );  
     my $hashref = &sign_params($url,$ckey,$secret,'',\%ltiparams);  
     if (ref($hashref) eq 'HASH') {  
         my $request=new HTTP::Request('POST',$url);  
         $request->content(join('&',map {  
                           my $name = escape($_);  
                           "$name=" . ( ref($hashref->{$_}) eq 'ARRAY'  
                           ? join("&$name=", map {escape($_) } @{$hashref->{$_}})  
                           : &escape($hashref->{$_}) );  
         } keys(%{$hashref})));  
         my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);  
         my $message=$response->status_line;  
         if (($response->is_success) && ($response->content ne '')) {  
             my %data = ();  
             my $count = 0;  
             my @state = ();  
             my @items = ('user_id','roles','person_sourcedid','person_name_given','person_name_family',  
                          'person_contact_email_primary','person_name_full','lis_result_sourcedid');  
             my $p = HTML::Parser->new  
             (  
              xml_mode => 1,  
              start_h =>  
                  [sub {  
                      my ($tagname, $attr) = @_;  
                      push(@state,$tagname);  
                      if ("@state" eq "message_response memberships member") {  
                          $count ++;  
                      }  
                  }, "tagname, attr"],  
              text_h =>  
                 [sub {  
                      my ($text) = @_;  
                      foreach my $item (@items) {  
                          if ("@state" eq "message_response memberships member $item") {  
                              $data{$count}{$item} = $text;  
                          }  
                      }  
                    }, "dtext"],  
              end_h =>  
                  [sub {  
                      my ($tagname) = @_;  
                      pop @state;  
                     }, "tagname"],  
             );              );
             $p->parse($response->content);              my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams,
             $p->eof;                                      '','','',1);
             return %data;              my $request=new HTTP::Request('POST',$service_url);
               $request->content($post);
               my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
         }          }
     }      }
     return;      return;
Line 646  sub get_roster { Line 298  sub get_roster {
 #  #
 # LON-CAPA as LTI Provider  # LON-CAPA as LTI Provider
 #  #
 # Passback a grade for a user to the LTI Consumer which originally  
 # provided the lis_result_sourcedid  
 #  
   
 sub send_grade {  
     my ($id,$url,$ckey,$secret,$scoretype,$total,$possible) = @_;  
     my $score;  
     if ($possible > 0) {  
         if ($scoretype eq 'ratio') {  
             $score = Math::Round::round($total).'/'.Math::Round::round($possible);  
         } elsif ($scoretype eq 'percentage') {  
             $score = (100.0*$total)/$possible;  
             $score = Math::Round::round($score);  
         } else {  
             $score = $total/$possible;  
             $score = sprintf("%.2f",$score);  
         }  
     }  
     my $date = &Apache::loncommon::utc_string(time);  
     my %ltiparams = (  
         lti_version                   => 'LTI-1p0',  
         lti_message_type              => 'basic-lis-updateresult',  
         sourcedid                     => $id,  
         result_resultscore_textstring => $score,  
         result_resultscore_language   => 'en-US',  
         result_resultvaluesourcedid   => $scoretype,  
         result_statusofresult         => 'final',  
         result_date                   => $date,  
     );  
     my $hashref = &sign_params($url,$ckey,$secret,'',\%ltiparams);  
     if (ref($hashref) eq 'HASH') {  
         my $request=new HTTP::Request('POST',$url);  
         $request->content(join('&',map {  
                           my $name = escape($_);  
                           "$name=" . ( ref($hashref->{$_}) eq 'ARRAY'  
                           ? join("&$name=", map {escape($_) } @{$hashref->{$_}})  
                           : &escape($hashref->{$_}) );  
         } keys(%{$hashref})));  
         my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);  
         my $message=$response->status_line;  
 #FIXME Handle case where pass back of score to LTI Consumer failed.  
     }  
 }  
   
 #  
 # LON-CAPA as LTI Provider  
 #  
 # Create a new user in LON-CAPA. If the domain's configuration   # Create a new user in LON-CAPA. If the domain's configuration 
 # includes rules for format of "official" usernames, those rules  # includes rules for format of "official" usernames, those rules
 # will apply when determining if a user is to be created.  In  # will apply when determining if a user is to be created.  In
Line 874  sub enrolluser { Line 479  sub enrolluser {
 #  #
 # LON-CAPA as LTI Provider  # LON-CAPA as LTI Provider
 #  #
 # Batch addition of users following LTI launch by a user  
 # with LTI Instructor status.  
 #  
 # A list of users is obtained by a call to get_roster()  
 # if the calling Consumer support the LTI extension:   
 # Context Memberships Service.   
 #  
 # If a user included in the retrieved list does not currently  
 # have a user account in LON-CAPA, an account will be created.  
 #  
 # If a user already has an account, and the same role and  
 # section assigned (currently active), then no change will  
 # be made for that user.  
 #  
 # Information available for new users (besides username and)  
 # role) may include: first name, last name, full name (from  
 # which middle name will be extracted), permanent e-mail address,  
 # and lis_result_sourcedid (for passback of grades).  
 #  
 # If grades are to be passed back, the passback url will be  
 # the same as for the current user's session.  
 #  
 # The roles which may be assigned will be determined from the  
 # LTI roles included in the retrieved roster, and the mapping  
 # of LTI roles to LON-CAPA roles configured for this LTI Consumer  
 # in the domain configuration.  
 #  
 # Course Coordinator roles will only be assigned if the current  
 # user is also the course owner.  
 #  
 # The domain configuration for the corresponding Consumer can include  
 # a section to assign to LTI users. If the roster includes students  
 # any existing student roles with a different section will be expired,  
 # and a role in the LTI section will be assigned.  
 #  
 # For non-student rules (excluding Course Coordinator) a role will be  
 # assigned with the LTI section )or no section, if one is not rquired.  
 #  
   
 sub batchaddroster {  
     my ($item) = @_;  
     return unless(ref($item) eq 'HASH');  
     return unless (ref($item->{'ltiref'}) eq 'HASH');  
     my ($cdom,$cnum) = split(/_/,$item->{'cid'});  
     my $udom = $cdom;  
     my $id = $item->{'id'};  
     my $url = $item->{'url'};  
     my @intdoms;  
     my $intdomsref = $item->{'intdoms'};  
     if (ref($intdomsref) eq 'ARRAY') {  
         @intdoms = @{$intdomsref};  
     }  
     my $uriscope = $item->{'uriscope'};  
     my $ckey = $item->{'ltiref'}->{'key'};  
     my $secret = $item->{'ltiref'}->{'secret'};  
     my $section = $item->{'ltiref'}->{'section'};  
     $section =~ s/\W//g;  
     if ($section eq 'none') {  
         undef($section);  
     } elsif ($section ne '') {  
         my %curr_groups =  
             &Apache::longroup::coursegroups($cdom,$cnum);  
         if (exists($curr_groups{$section})) {  
             undef($section);  
         }  
     }  
     my (%maproles,@possroles);  
     if (ref($item->{'ltiref'}->{'maproles'}) eq 'HASH') {  
         %maproles = %{$item->{'ltiref'}->{'maproles'}};  
     }  
     if (ref($item->{'possroles'}) eq 'ARRAY') {  
         @possroles = @{$item->{'possroles'}};  
     }  
     if (($ckey ne '') && ($secret ne '') && ($id ne '') && ($url ne '')) {  
         my %data = &get_roster($id,$url,$ckey,$secret);  
         if (keys(%data) > 0) {  
             my (%rulematch,%inst_results,%curr_rules,%got_rules,%alerts,%info);  
             my %coursehash = &Apache::lonnet::coursedescription($cdom.'_'.$cnum);  
             my $start = $coursehash{'default_enrollment_start_date'};  
             my $end = $coursehash{'default_enrollment_end_date'};  
             my $domdesc = &Apache::lonnet::domain($udom,'description');  
             my $roster = &Apache::loncoursedata::get_classlist($cdom,$cnum);  
             my $status = &Apache::loncoursedata::CL_STATUS;  
             my $cend = &Apache::loncoursedata::CL_END;  
             my $cstart = &Apache::loncoursedata::CL_START;  
             my $lockedtype=&Apache::loncoursedata::CL_LOCKEDTYPE;  
             my $sec=&Apache::loncoursedata::CL_SECTION;  
             my (@activestudents,@futurestudents,@excludedstudents,@localstudents,%currlist,%advroles);  
             if (grep(/^st$/,@possroles)) {  
                 foreach my $user (keys(%{$roster})) {  
                     if ($user =~ m/^(.+):$cdom$/) {  
                         my $stuname = $1;  
                         if ($roster->{$user}[$status] eq "Active") {  
                             push(@activestudents,$stuname);  
                             @{$currlist{$stuname}} = @{$roster->{$user}};  
                             push(@localstudents,$stuname);  
                         } elsif (($roster->{$user}[$cstart] > time)  && ($roster->{$user}[$cend] > time ||  
                                   $roster->{$user}[$cend] == 0 || $roster->{$user}[$cend] eq '')) {  
                             push(@futurestudents,$stuname);  
                             @{$currlist{$stuname}} = @{$roster->{$user}};  
                             push(@localstudents,$stuname);  
                         } elsif ($roster->{$user}[$lockedtype] == 1) {  
                             push(@excludedstudents,$stuname);  
                         }  
                     }  
                 }  
             }  
             if ((@possroles > 1) || ((@possroles == 1) && (!grep(/^st$/,@possroles)))) {  
                 my %personnel = &Apache::lonnet::get_course_adv_roles($item->{'cid'},1);  
                 foreach my $item (keys(%personnel)) {  
                     my ($role,$currsec) = split(/:/,$item);  
                     if ($currsec eq '') {  
                         $currsec = 'none';  
                     }  
                     foreach my $user (split(/,/,$personnel{$item})) {  
                         push(@{$advroles{$user}{$role}},$currsec);  
                     }  
                 }  
             }  
             if (($end == 0) || ($end > time) || (@localstudents > 0)) {  
                 my (%passback,$pbnum,$numadv);  
                 $numadv = 0;  
                 foreach my $i (sort { $a <=> $b } keys(%data)) {  
                     if (ref($data{$i}) eq 'HASH') {  
                         my $entry = $data{$i};  
                         my $user = $entry->{'person_sourcedid'};  
                         my $uname;  
                         if ($user =~ /^($match_username):($match_domain)$/) {  
                             $uname = $1;  
                             my $possudom = $2;  
                             if ($possudom ne $udom) {  
                                 my $uintdom = &Apache::lonnet::domain($possudom,'primary');  
                                 if (($uintdom ne '') && (grep(/^\Q$uintdom\E$/,@intdoms))) {  
                                     $udom = $possudom;  
                                 }  
                             }  
                         } elsif ($uname =~ /^match_username$/) {  
                             $uname = $user;  
                         } else {  
                             next;  
                         }  
                         my $uhome = &Apache::lonnet::homeserver($uname,$udom);  
                         if ($uhome eq 'no_host') {  
                             my %data;  
                             $data{'permanentemail'} = $entry->{'person_contact_email_primary'};  
                             $data{'lastname'} = $entry->{'person_name_family'};  
                             $data{'firstname'} = $entry->{'person_name_given'};  
                             $data{'fullname'} = $entry->{'person_name_full'};  
                             my $addresult =  
                                 &create_user($item->{'ltiref'},$uname,$udom,  
                                              $domdesc,\%data,\%alerts,\%rulematch,  
                                              \%inst_results,\%curr_rules,\%got_rules);  
                             next unless ($addresult eq 'ok');  
                         }  
                         if ($env{'request.lti.passbackurl'}) {  
                             if ($entry->{'lis_result_sourcedid'} ne '') {  
                                 unless ($pbnum) {  
                                     ($pbnum,my $error) = &store_passbackurl($env{'request.lti.login'},  
                                                                             $env{'request.lti.passbackurl'},  
                                                                             $cdom,$cnum);  
                                     if ($pbnum eq '') {  
                                         $pbnum = $env{'request.lti.passbackurl'};  
                                     }  
                                 }  
                                 $passback{$uname."\0".$uriscope."\0".$env{'request.lti.sourcecrs'}."\0".$env{'request.lti.login'}} =  
                                           $pbnum."\0".$entry->{'lis_result_sourcedid'};  
                             }  
                         }  
                         my $rolestr = $entry->{'roles'};  
                         my ($lcrolesref) = &get_lc_roles($rolestr,\@possroles,\%maproles);  
                         my @lcroles = @{$lcrolesref};  
                         if (@lcroles) {  
                             if (grep(/^st$/,@lcroles)) {  
                                 my $addstu;  
                                 if (!grep(/^\Q$uname\E$/,@excludedstudents)) {  
                                     if (grep(/^\Q$uname\E$/,@localstudents)) {  
 # Check for section changes  
                                         if ($currlist{$uname}[$sec] ne $section) {  
                                             $addstu = 1;  
                                             &Apache::lonuserutils::modifystudent($udom,$uname,$cdom.'_'.$cnum,  
                                                                                  undef,undef,'course');  
                                         } elsif (grep(/^\Q$uname\E$/,@futurestudents)) {  
 # Check for access date changes for students with access starting in the future.  
                                             my $datechange = &datechange_check($currlist{$uname}[$cstart],  
                                                                                $currlist{$uname}[$cend],  
                                                                                $start,$end);  
                                             if ($datechange) {  
                                                 $addstu = 1;  
                                             }  
                                         }  
                                     } else {  
                                         $addstu = 1;  
                                     }  
                                 }  
                                 unless ($addstu) {  
                                     pop(@lcroles);  
                                 }  
                             }  
                             my @okroles;  
                             if (@lcroles) {  
                                 foreach my $role (@lcroles) {  
                                     unless (($role eq 'st') || (keys(%advroles) == 0)) {  
                                         if (exists($advroles{$uname.':'.$udom})) {  
                                             if ((ref($advroles{$uname.':'.$udom}) eq 'HASH') &&  
                                                 (ref($advroles{$uname.':'.$udom}{$role}) eq 'ARRAY')) {  
                                                 if (($section eq '') || ($role eq 'cc') || ($role eq 'co')) {  
                                                     next if (grep(/^none$/,@{$advroles{$uname.':'.$udom}{$role}}));  
                                                 } else {  
                                                     next if (grep(/^\Q$sec\E$/,@{$advroles{$uname.':'.$udom}{$role}}));  
                                                 }  
                                             }  
                                         }  
                                     }  
                                     push(@okroles,$role);  
                                 }  
                             }  
                             if (@okroles) {  
                                 my $permanentemail = $entry->{'person_contact_email_primary'};  
                                 my $lastname = $entry->{'person_name_family'};  
                                 my $firstname = $entry->{'person_name_given'};  
                                 foreach my $role (@okroles) {  
                                     my $enrollresult = &enrolluser($udom,$uname,$role,$cdom,$cnum,  
                                                                    $section,$start,$end);  
                                     if (($enrollresult eq 'ok') && ($role ne 'st')) {  
                                         $numadv ++;  
                                     }  
                                 }  
                             }  
                         }  
                     }  
                 }  
                 if (keys(%passback)) {  
                     &Apache::lonnet::put('nohist_lti_passback',\%passback,$cdom,$cnum);  
                 }  
                 if ($numadv) {  
                     &Apache::lonnet::flushcourselogs();  
                 }  
             }  
         }  
     }  
     return;  
 }  
   
 #  
 # LON-CAPA as LTI Provider  
 #  
 # Gather a list of available LON-CAPA roles derived  # Gather a list of available LON-CAPA roles derived
 # from a comma separated list of LTI roles.  # from a comma separated list of LTI roles.
 #  #
Line 1178  sub get_lc_roles { Line 537  sub get_lc_roles {
     return (\@lcroles,\@ltiroles);      return (\@lcroles,\@ltiroles);
 }  }
   
 #  
 # LON-CAPA as LTI Provider  
 #  
 # Compares current start and dates for a user's role  
 # with dates to apply for the same user/role to   
 # determine if there is a change between the current  
 # ones and the updated ones.  
 #   
   
 sub datechange_check {  
     my ($oldstart,$oldend,$startdate,$enddate) = @_;  
     my $datechange = 0;  
     unless ($oldstart eq $startdate) {  
         $datechange = 1;  
     }  
     if (!$datechange) {  
         if (!$oldend) {  
             if ($enddate) {  
                 $datechange = 1;  
             }  
         } elsif ($oldend ne $enddate) {  
             $datechange = 1;  
         }  
     }  
     return $datechange;  
 }  
   
 #  
 # LON-CAPA as LTI Provider  
 #  
 # Store the URL used by a specific LTI Consumer to process grades passed back  
 # by an LTI Provider.  
 #  
   
 sub store_passbackurl {  
     my ($ltinum,$pburl,$cdom,$cnum) = @_;  
     my %history = &Apache::lonnet::restore($ltinum,'passbackurl',$cdom,$cnum);  
     my ($pbnum,$version,$error);  
     if ($history{'version'}) {  
         $version = $history{'version'};  
         for (my $i=1; $i<=$version; $i++) {  
             if ($history{$i.':pburl'} eq $pburl) {  
                 $pbnum = $i;  
                 last;  
             }  
         }  
     } else {  
         $version = 0;  
     }  
     if ($pbnum eq '') {  
         # get lock on passbackurl db  
         my $now = time;  
         my $lockhash = {  
             'lock'."\0".$ltinum."\0".$now => $env{'user.name'}.':'.$env{'user.domain'},  
         };  
         my $tries = 0;  
         my $gotlock = &Apache::lonnet::newput('passbackurl',$lockhash,$cdom,$cnum);  
         while (($gotlock ne 'ok') && ($tries<3)) {  
             $tries ++;  
             sleep 1;  
             $gotlock = &Apache::lonnet::newput('passbackurl',$lockhash,$cdom.$cnum);  
         }  
         if ($gotlock eq 'ok') {  
             if (&Apache::lonnet::store_userdata({pburl => $pburl},  
                                                  $ltinum,'passbackurl',$cdom,$cnum) eq 'ok') {  
                 $pbnum = 1+$version;  
             }  
             my $dellock = &Apache::lonnet::del('passbackurl',['lock'."\0".$ltinum."\0".$now],$cdom,$cnum);  
             unless ($dellock eq 'ok') {  
                 $error = &mt('error: could not release lockfile');  
             }  
         } else {  
             $error = &mt('error: could not obtain lockfile');  
         }  
     }  
     return ($pbnum,$error);  
 }  
   
 1;  1;
Removed from v.1.13  
changed lines
  Added in v.1.17.2.1

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