--- loncom/lti/ltiutils.pm 2019/03/31 18:48:33 1.16
+++ loncom/lti/ltiutils.pm 2022/01/03 18:35:27 1.17.2.1
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Utility functions for managing LON-CAPA LTI interactions
#
-# $Id: ltiutils.pm,v 1.16 2019/03/31 18:48:33 raeburn Exp $
+# $Id: ltiutils.pm,v 1.17.2.1 2022/01/03 18:35:27 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -31,15 +31,8 @@ package LONCAPA::ltiutils;
use strict;
use Net::OAuth;
use Digest::SHA;
-use UUID::Tiny ':std';
use Apache::lonnet;
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);
#
@@ -94,148 +87,6 @@ sub check_nonce {
#
# 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
# secret for the specific LTI Provider.
#
@@ -270,83 +121,26 @@ sub verify_request {
#
# 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
# tool in a LON-CAPA course, using the key and secret supplied
# by the Tool Provider.
#
sub sign_params {
- my ($url,$key,$secret,$sigmethod,$paramsref) = @_;
+ my ($url,$key,$secret,$paramsref,$sigmethod,$type,$callback,$post) = @_;
return unless (ref($paramsref) eq 'HASH');
if ($sigmethod eq '') {
$sigmethod = 'HMAC-SHA1';
}
+ if ($type eq '') {
+ $type = 'request token';
+ }
+ if ($callback eq '') {
+ $callback = 'about:blank',
+ }
srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
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_secret => $secret,
request_url => $url,
@@ -354,173 +148,19 @@ sub sign_params {
signature_method => $sigmethod,
timestamp => time,
nonce => $nonce,
- callback => 'about:blank',
+ callback => $callback,
extra_params => $paramsref,
version => '1.0',
);
$request->sign();
- return $request->to_hash();
-}
-
-#
-# 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';
+ if ($post) {
+ return $request->to_post_body();
} else {
- return 'ok';
+ return $request->to_hash();
}
}
#
-# 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
#
# Use the part of the launch URL after /adm/lti to determine
@@ -633,66 +273,23 @@ 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 ($id,$url,$ckey,$secret) = @_;
- my %ltiparams = (
- lti_version => 'LTI-1p0',
- 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"],
+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_utf8($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,
);
- $p->parse($response->content);
- $p->eof;
- return %data;
+ my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams,
+ '','','',1);
+ my $request=new HTTP::Request('POST',$service_url);
+ $request->content($post);
+ my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
}
}
return;
@@ -701,115 +298,6 @@ sub get_roster {
#
# 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,$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 $hashref = &sign_params($url,$ckey,$secret,$sigmethod,\%ltiparams);
- if (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})));
- }
- } else {
- srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
- my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));
- 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 $gradereq = Net::OAuth->request('consumer')->new(
- consumer_key => $ckey,
- consumer_secret => $secret,
- request_url => $url,
- request_method => 'POST',
- signature_method => $sigmethod,
- timestamp => time(),
- nonce => $nonce,
- body_hash => $bodyhash,
- );
- $gradereq->add_required_message_params('body_hash');
- $gradereq->sign();
- $request = HTTP::Request->new(
- $gradereq->request_method,
- $gradereq->request_url,
- [
- 'Authorization' => $gradereq->to_authorization_header,
- 'Content-Type' => 'application/xml',
- ],
- $gradexml,
- );
- }
- 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
# includes rules for format of "official" usernames, those rules
# will apply when determining if a user is to be created. In
@@ -991,252 +479,6 @@ sub enrolluser {
#
# 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
# from a comma separated list of LTI roles.
#
@@ -1295,82 +537,4 @@ sub get_lc_roles {
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;