--- loncom/lti/ltiutils.pm 2023/01/23 18:39:46 1.17.2.3 +++ loncom/lti/ltiutils.pm 2023/07/05 21:25:10 1.17.2.4 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Utility functions for managing LON-CAPA LTI interactions # -# $Id: ltiutils.pm,v 1.17.2.3 2023/01/23 18:39:46 raeburn Exp $ +# $Id: ltiutils.pm,v 1.17.2.4 2023/07/05 21:25:10 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -33,9 +33,17 @@ use Net::OAuth; use Digest::SHA; use Digest::MD5 qw(md5_hex); use Encode; +use UUID::Tiny ':std'; use LWP::UserAgent(); 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::Lond; use LONCAPA qw(:DEFAULT :match); # @@ -90,10 +98,173 @@ 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 ($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 # secret for the specific LTI Provider. # +# FIXME Move to Lond.pm and perform on course's homeserver + sub verify_request { my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params, $authheaders,$errors) = @_; @@ -124,6 +295,69 @@ 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. @@ -164,6 +398,164 @@ 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 oldsecret, and a new secret +# 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 # # Use the part of the launch URL after /adm/lti to determine @@ -276,8 +668,194 @@ 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 = < + + + + V1.0 + $uniqmsgid + + + + + + + $id + + + + en + $score + + + + + + +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 { - 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?://[^/]+/}) { my $digest_user = &Encode::decode('UTF-8',$uname.':'.$udom); my $loginfile = &Digest::SHA::sha1_hex($digest_user).&md5_hex(&md5_hex(time.{}.rand().$$)); @@ -288,14 +866,19 @@ sub setup_logout_callback { my %ltiparams = ( callback => $callback, ); - my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams, - '','','',1); - - my $ua=new LWP::UserAgent; - $ua->timeout(10); - my $request=new HTTP::Request('POST',$service_url); - $request->content($post); - my $response=$ua->request($request); + my %info = ( + respfmt => 'to_post_body', + ); + my ($status,$post) = + &Apache::lonnet::sign_lti($cdom,$cnum,$crstool,'lti','logout',$service_url,$idx, + $keynum,\%ltiparams,\%info); + if (($status eq 'ok') && ($post ne '')) { + 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; @@ -485,6 +1068,253 @@ 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') && + (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 # from a comma separated list of LTI roles. # @@ -543,4 +1373,82 @@ 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;