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

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

version 1.17.2.3, 2023/01/23 18:39:46 version 1.17.2.4, 2023/07/05 21:25:10
Line 33  use Net::OAuth; Line 33  use Net::OAuth;
 use Digest::SHA;  use Digest::SHA;
 use Digest::MD5 qw(md5_hex);  use Digest::MD5 qw(md5_hex);
 use Encode;  use Encode;
   use UUID::Tiny ':std';
 use LWP::UserAgent();   use LWP::UserAgent(); 
 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::Lond;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
   
 #  #
Line 90  sub check_nonce { Line 98  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 ($crsdef,$ltinum);
               if ($idx =~ /^c(\d+)$/) {
                   $ltinum = $1;
                   $crsdef = 1;
                   my %crslti = &Apache::lonnet::get_course_lti($cnum,$cdom,'consumer');
                   if (ref($crslti{$ltinum}) eq 'HASH') {
                       %{$ltitools} = %{$crslti{$ltinum}};
                   } else {
                       undef($ltinum);
                   }
               } elsif ($idx =~ /^\d+$/) {
                   my %lti = &Apache::lonnet::get_domain_lti($cdom,'consumer');
                   if (ref($lti{$idx}) eq 'HASH') {
                       %{$ltitools} = %{$lti{$idx}};
                       $ltinum = $idx;
                   }
               }
               if ($ltinum ne '') {
                   my $loncaparev = &Apache::lonnet::get_server_loncaparev($cdom);
                   my $keynum = $ltitools->{'cipher'};
                   my ($poss_key,$poss_secret) =
                       &LONCAPA::Lond::get_lti_credentials($cdom,$cnum,$crsdef,'tools',$ltinum,$keynum,$loncaparev);
                   if ($poss_key eq $key) {
                       $consumer_secret = $poss_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.
 #  #
   
   # FIXME Move to Lond.pm and perform on course's homeserver
   
 sub verify_request {  sub verify_request {
     my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,      my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
         $authheaders,$errors) = @_;          $authheaders,$errors) = @_;
Line 124  sub verify_request { Line 295  sub verify_request {
 #  #
 # LON-CAPA as LTI Consumer  # LON-CAPA as LTI Consumer
 #  #
   # Verify that an item identifier (either roster request:
   # ext_ims_lis_memberships_id, or grade store:
   # lis_result_sourcedid) has not been tampered with, and
   # 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'} * 86400; # convert days to seconds
       } 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->{18} = 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->{19} = 1;
                   }
               }
           } else {
               $errors->{20} = 1;
           }
       } else {
           $errors->{21} = 1;
       }
       return;
   }
   
   #
   # LON-CAPA as LTI Consumer
   #
 # Sign a request used to launch an instance of an external  # Sign a request used to launch an instance of an external
 # tool in a LON-CAPA course, using the key and secret supplied   # tool in a LON-CAPA course, using the key and secret supplied 
 # by the Tool Provider.  # by the Tool Provider.
Line 164  sub sign_params { Line 398  sub sign_params {
 }  }
   
 #  #
   # 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'} * 86400; # convert days to seconds
       } elsif ($name eq 'roster') {
           $lifetime = $ltitools->{'rostervalid'};
       }
       if ($toolsettings->{$name.'secret'} eq '') {
           $needsnew = 1;
       } elsif (($toolsettings->{$name.'secretdate'} + $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 {
           return 'ok';
       }
   }
   
   #
   # LON-CAPA as LTI Consumer
   #
   # Parse XML containing grade data sent by an LTI Provider
   #
   
   sub parse_grade_xml {
       my ($xml) = @_;
       my %data = ();
       my $count = 0;
       my @state = ();
       my $p = HTML::Parser->new(
           xml_mode => 1,
           start_h =>
               [sub {
                   my ($tagname, $attr) = @_;
                   push(@state,$tagname);
                   if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord") {
                       $count ++;
                   }
               }, "tagname, attr"],
           text_h =>
               [sub {
                   my ($text) = @_;
                   if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord sourcedGUID sourcedId") {
                       $data{$count}{sourcedid} = $text;
                   } elsif ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord result resultScore textString") {
                       $data{$count}{score} = $text;
                   }
               }, "dtext"],
           end_h =>
               [sub {
                    my ($tagname) = @_;
                    pop @state;
                   }, "tagname"],
       );
       $p->parse($xml);
       $p->eof;
       return %data;
   }
   
   #
 # LON-CAPA as LTI Provider  # LON-CAPA as LTI Provider
 #  #
 # Use the part of the launch URL after /adm/lti to determine  # Use the part of the launch URL after /adm/lti to determine
Line 276  sub lti_provider_scope { Line 668  sub lti_provider_scope {
     }      }
 }  }
   
   #
   # LON-CAPA as LTI Provider
   #
   # Obtain a list of course personnel and students from
   # the LTI Consumer which launched this instance.
   #
   
   sub get_roster {
       my ($cdom,$cnum,$ltinum,$keynum,$id,$url) = @_;
       my %ltiparams = (
           lti_version                => 'LTI-1p0',
           lti_message_type           => 'basic-lis-readmembershipsforcontext',
           ext_ims_lis_memberships_id => $id,
       );
       my %info = ();
       my ($status,$hashref) =
           &Apache::lonnet::sign_lti($cdom,$cnum,'','lti','roster',$url,$ltinum,$keynum,\%ltiparams,\%info);
       if (($status eq 'ok') && (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 $ua=new LWP::UserAgent;
           $ua->timeout(10);
           my $response=$ua->request($request);
           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);
               $p->eof;
               return %data;
           }
       }
       return;
   }
   
   #
   # 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 ($cdom,$cnum,$crsdef,$type,$ltinum,$keynum,$id,$url,$scoretype,$sigmethod,$msgformat,$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);
           }
       }
       if ($sigmethod eq '') {
           $sigmethod = 'HMAC-SHA1';
       }
       my $request;
       if ($msgformat eq '1.0') {
           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 %info = (
                           method => $sigmethod,
                      );
           my ($status,$hashref) =
               &Apache::lonnet::sign_lti($cdom,$cnum,$crsdef,$type,'grade',$url,$ltinum,$keynum,
                                         \%ltiparams,\%info);
           if (($status eq 'ok') && (ref($hashref) eq 'HASH')) {
               $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})));
   #FIXME Need to handle case where passback failed.
           }
       } else {
           srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.
           my $uniqmsgid = int(rand(2**32));
           my $gradexml = <<END;
   <?xml version = "1.0" encoding = "UTF-8"?>
   <imsx_POXEnvelopeRequest xmlns = "http://www.imsglobal.org/services/ltiv1p1/xsd/imsoms_v1p0">
     <imsx_POXHeader>
       <imsx_POXRequestHeaderInfo>
         <imsx_version>V1.0</imsx_version>
         <imsx_messageIdentifier>$uniqmsgid</imsx_messageIdentifier>
       </imsx_POXRequestHeaderInfo>
     </imsx_POXHeader>
     <imsx_POXBody>
       <replaceResultRequest>
         <resultRecord>
           <sourcedGUID>
             <sourcedId>$id</sourcedId>
           </sourcedGUID>
           <result>
             <resultScore>
               <language>en</language>
               <textString>$score</textString>
             </resultScore>
           </result>
         </resultRecord>
       </replaceResultRequest>
     </imsx_POXBody>
   </imsx_POXEnvelopeRequest>
   END
           chomp($gradexml);
           my $bodyhash = Digest::SHA::sha1_base64($gradexml);
           while (length($bodyhash) % 4) {
               $bodyhash .= '=';
           }
           my $reqmethod = 'POST';
           my %info = (
                         body_hash => $bodyhash,
                         method => $sigmethod,
                         reqtype => 'consumer',
                         reqmethod => $reqmethod,
                         respfmt => 'to_authorization_header',
                      );
           my %params;
           my ($status,$authheader) =
               &Apache::lonnet::sign_lti($cdom,$cnum,$crsdef,$type,'grade',$url,$ltinum,$keynum,\%params,\%info);
           if (($status eq 'ok') && ($authheader ne '')) {
               $request = HTTP::Request->new(
                              $reqmethod,
                              $url,
                              [
                                 'Authorization' => $authheader,
                                 'Content-Type'  => 'application/xml',
                              ],
                              $gradexml,
               );
               my $ua=new LWP::UserAgent;
               $ua->timeout(10);
               my $response=$ua->request($request);
               my $message=$response->status_line;
   #FIXME Handle case where pass back of score to LTI Consumer failed.
           }
       }
   }
   
 sub setup_logout_callback {  sub setup_logout_callback {
     my ($uname,$udom,$server,$ckey,$secret,$service_url,$idsdir,$protocol,$hostname) = @_;      my ($cdom,$cnum,$crstool,$idx,$keynum,$uname,$udom,$server,$service_url,$idsdir,$protocol,$hostname) = @_;
     if ($service_url =~ m{^https?://[^/]+/}) {      if ($service_url =~ m{^https?://[^/]+/}) {
         my $digest_user = &Encode::decode('UTF-8',$uname.':'.$udom);          my $digest_user = &Encode::decode('UTF-8',$uname.':'.$udom);
         my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$));          my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$));
Line 288  sub setup_logout_callback { Line 866  sub setup_logout_callback {
             my %ltiparams = (              my %ltiparams = (
                 callback   => $callback,                  callback   => $callback,
             );              );
             my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams,              my %info = (
                                     '','','',1);                  respfmt => 'to_post_body',
               );
             my $ua=new LWP::UserAgent;              my ($status,$post) =
             $ua->timeout(10);                  &Apache::lonnet::sign_lti($cdom,$cnum,$crstool,'lti','logout',$service_url,$idx,
             my $request=new HTTP::Request('POST',$service_url);                                            $keynum,\%ltiparams,\%info);
             $request->content($post);              if (($status eq 'ok') && ($post ne '')) {
             my $response=$ua->request($request);                   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;      return;
Line 485  sub enrolluser { Line 1068  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') &&
                     (ref($item->{'ltiref'}) eq 'HASH'));
       my ($cdom,$cnum) = split(/_/,$item->{'cid'});
       return if (($cdom eq '') || ($cnum eq ''));
       my $udom = $cdom;
       my $id = $item->{'id'};
       my $url = $item->{'url'};
       my $ltinum = $item->{'lti'};
       my $keynum = $item->{'ltiref'}->{'cipher'};
       my @intdoms;
       my $intdomsref = $item->{'intdoms'};
       if (ref($intdomsref) eq 'ARRAY') {
           @intdoms = @{$intdomsref};
       }
       my $uriscope = $item->{'uriscope'};
       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 (($id ne '') && ($url ne '')) {
           my %data = &get_roster($cdom,$cnum,$ltinum,$keynum,$id,$url);
           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 543  sub get_lc_roles { Line 1373  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.17.2.3  
changed lines
  Added in v.1.17.2.4

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