--- loncom/lti/ltiutils.pm 2018/05/28 23:26:04 1.11 +++ loncom/lti/ltiutils.pm 2022/01/20 00:35:00 1.17.2.2 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Utility functions for managing LON-CAPA LTI interactions # -# $Id: ltiutils.pm,v 1.11 2018/05/28 23:26:04 raeburn Exp $ +# $Id: ltiutils.pm,v 1.17.2.2 2022/01/20 00:35:00 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -31,14 +31,10 @@ package LONCAPA::ltiutils; use strict; use Net::OAuth; use Digest::SHA; -use UUID::Tiny ':std'; +use Digest::MD5 qw(md5_hex); +use LWP::UserAgent(); use Apache::lonnet; use Apache::loncommon; -use Apache::loncoursedata; -use Apache::lonuserutils; -use Apache::lonenc(); -use Apache::longroup(); -use Math::Round(); use LONCAPA qw(:DEFAULT :match); # @@ -93,226 +89,35 @@ 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. # sub verify_request { - my ($params,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$errors) = @_; - return unless (ref($errors) eq 'HASH'); - my $request = Net::OAuth->request('request token')->from_hash($params, - request_url => $protocol.'://'.$hostname.$requri, - request_method => $reqmethod, - consumer_secret => $consumer_secret,); - unless ($request->verify()) { + my ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params, + $authheaders,$errors) = @_; + unless (ref($errors) eq 'HASH') { $errors->{15} = 1; return; } -} - -# -# 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'} - } elsif ($context eq 'roster') { - $has_action = $ltitools->{'roster'}; - $valid_for = $ltitools->{'rostervalid'}; - } - if ($has_action) { - my $secret; - if (($toolsettings->{$context.'secretdate'} + $valid_for) > time) { - $secret = $toolsettings->{$context.'secret'}; - } else { - $secret = $toolsettings->{'old'.$context.'secret'}; - } - if ($secret) { - my $expected_sig; - if ($context eq 'grade') { - my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum; - $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; - if ($expected_sig eq $sigrec) { - return 1; - } else { - $errors->{17} = 1; - } - } elsif ($context eq 'roster') { - my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum; - $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; - if ($expected_sig eq $sigrec) { - return 1; - } else { - $errors->{18} = 1; - } - } - } else { - $errors->{19} = 1; - } + my $request; + if ($oauthtype eq 'consumer') { + my $oauthreq = Net::OAuth->request('consumer'); + $oauthreq->add_required_message_params('body_hash'); + $request = $oauthreq->from_authorization_header($authheaders, + request_url => $protocol.'://'.$hostname.$requri, + request_method => $reqmethod, + consumer_secret => $consumer_secret,); } else { - $errors->{20} = 1; + $request = Net::OAuth->request('request token')->from_hash($params, + request_url => $protocol.'://'.$hostname.$requri, + request_method => $reqmethod, + consumer_secret => $consumer_secret,); + } + unless ($request->verify()) { + $errors->{15} = 1; + return; } - return; } # @@ -324,14 +129,20 @@ sub verify_lis_item { # 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, @@ -339,128 +150,15 @@ 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 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'} - } elsif ($name eq 'roster') { - $lifetime = $ltitools->{'rostervalid'}; - } - if ($toolsettings->{$name} eq '') { - $needsnew = 1; - } elsif (($toolsettings->{$name.'date'} + $lifetime) < $now) { - $oldsecret = $toolsettings->{$name.'secret'}; - $needsnew = 1; - } - if ($needsnew) { - if (&get_tool_lock($cdom,$cnum,$marker,$name,$now) eq 'ok') { - my $secret = UUID::Tiny::create_uuid_as_string(UUID_V4); - $toolsettings->{$name.'secret'} = $secret; - my %secrethash = ( - $name.'secret' => $secret, - $name.'secretdate' => $now, - ); - if ($oldsecret ne '') { - $secrethash{'old'.$name.'secret'} = $oldsecret; - } - my $putres = &Apache::lonnet::put('exttool_'.$marker, - \%secrethash,$cdom,$cnum); - my $delresult = &release_tool_lock($cdom,$cnum,$marker,$name); - if ($delresult ne 'ok') { - $warning = $delresult ; - } - if ($putres eq 'ok') { - return 'ok'; - } - } else { - $warning = 'Could not obtain exclusive lock'; - } - } else { - return 'ok'; - } - return; -} - -# -# LON-CAPA as LTI Consumer -# -# Add a lock key to exttools.db for the instance of an external tool -# when generating and storing a service secret. -# - -sub get_tool_lock { - my ($cdom,$cnum,$marker,$name,$now) = @_; - # get lock for tool for which secret is being set - my $lockhash = { - $name."\0".$marker."\0".'lock' => $now.':'.$env{'user.name'}. - ':'.$env{'user.domain'}, - }; - my $tries = 0; - my $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum); - - while (($gotlock ne 'ok') && $tries <3) { - $tries ++; - sleep(1); - $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum); - } - return $gotlock; -} - -# -# LON-CAPA as LTI Consumer -# -# Remove a lock key from exttools.db for the instance of an external -# tool created when generating and storing a service secret. -# - -sub release_tool_lock { - my ($cdom,$cnum,$marker,$name) = @_; - # remove lock - my @del_lock = ($name."\0".$marker."\0".'lock'); - my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum); - if ($dellockoutcome ne 'ok') { - return 'Warning: failed to release lock for exttool'; + $request->sign(); + if ($post) { + return $request->to_post_body(); } else { - return 'ok'; + return $request->to_hash(); } } @@ -487,16 +185,18 @@ sub lti_provider_scope { $scope = 'map'; $realuri = $tail; } else { - my ($map,$resid,$url) = &Apache::lonnet::decode_symb($tail); + my $symb = $tail; + $symb =~ s{^/}{}; + my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb); $realuri = &Apache::lonnet::clutter($url); if ($url =~ /\.sequence$/) { $scope = 'map'; } else { $scope = 'resource'; - $realuri .= '?symb='.$tail; - $passkey = $tail; + $realuri .= '?symb='.$symb; + $passkey = $symb; if ($getunenc) { - $unencsymb = $tail; + $unencsymb = $symb; } } } @@ -506,16 +206,18 @@ sub lti_provider_scope { $scope = 'map'; $realuri = $tail; } else { - my ($map,$resid,$url) = &Apache::lonnet::decode_symb($tail); + my $symb = $tail; + $symb =~ s{^/?res/}{}; + my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb); $realuri = &Apache::lonnet::clutter($url); if ($url =~ /\.sequence$/) { $scope = 'map'; } else { $scope = 'resource'; - $realuri .= '?symb='.$tail; - $passkey = $tail; + $realuri .= '?symb='.$symb; + $passkey = $symb; if ($getunenc) { - $unencsymb = $tail; + $unencsymb = $symb; } } } @@ -561,7 +263,7 @@ sub lti_provider_scope { } elsif (($tail =~ m{^/$cdom/$cnum$}) || ($tail eq '')) { $scope = 'course'; $realuri = '/adm/navmaps'; - $passkey = $tail; + $passkey = ''; } if ($scope eq 'map') { $passkey = $realuri; @@ -573,103 +275,40 @@ sub lti_provider_scope { } } -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 $ua=new LWP::UserAgent; + $ua->timeout(10); + my $request=new HTTP::Request('POST',$service_url); + $request->content($post); + my $response=$ua->request($request); } } return; } -sub send_grade { - my ($id,$url,$ckey,$secret,$scoretype,$total,$possible) = @_; - my $score; - if ($possible > 0) { - if ($scoretype eq 'ratio') { - $score = Math::Round::round($total).'/'.Math::Round::round($possible); - } elsif ($scoretype eq 'percentage') { - $score = (100.0*$total)/$possible; - $score = Math::Round::round($score); - } else { - $score = $total/$possible; - $score = sprintf("%.2f",$score); - } - } - my $date = &Apache::loncommon::utc_string(time); - my %ltiparams = ( - lti_version => 'LTI-1p0', - lti_message_type => 'basic-lis-updateresult', - sourcedid => $id, - result_resultscore_textstring => $score, - result_resultscore_language => 'en-US', - result_resultvaluesourcedid => $scoretype, - result_statusofresult => 'final', - result_date => $date, - ); - my $hashref = &sign_params($url,$ckey,$secret,\%ltiparams); - if (ref($hashref) eq 'HASH') { - my $request=new HTTP::Request('POST',$url); - $request->content(join('&',map { - my $name = escape($_); - "$name=" . ( ref($hashref->{$_}) eq 'ARRAY' - ? join("&$name=", map {escape($_) } @{$hashref->{$_}}) - : &escape($hashref->{$_}) ); - } keys(%{$hashref}))); - my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10); - my $message=$response->status_line; -#FIXME Handle case where pass back of score to LTI Consumer failed. - } -} +# +# LON-CAPA as LTI Provider +# +# Create a new user in LON-CAPA. If the domain's configuration +# includes rules for format of "official" usernames, those rules +# will apply when determining if a user is to be created. In +# additional if institutional user information is available that +# will be used when creating a new user account. +# sub create_user { my ($ltiref,$uname,$udom,$domdesc,$data,$alerts,$rulematch,$inst_results, @@ -768,8 +407,17 @@ sub create_user { return $result; } +# +# LON-CAPA as LTI Provider +# +# Create a password for a new user if the authentication +# type to assign to new users created following LTI launch is +# to be LON-CAPA "internal". +# + sub create_passwd { my $passwd = ''; + srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand. my @letts = ("a".."z"); for (my $i=0; $i<8; $i++) { my $lettnum = int(rand(2)); @@ -788,8 +436,20 @@ sub create_passwd { return ($passwd); } +# +# LON-CAPA as LTI Provider +# +# Enroll a user in a LON-CAPA course, with the specified role and (optional) +# section. If this is a self-enroll case, i.e., a user launched the LTI tool +# in the Consumer, user privs will be added to the user's environment for +# the new role. +# +# If this is a self-enroll case, a Course Coordinator role will only be assigned +# if the current user is also the course owner. +# + sub enrolluser { - my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end) = @_; + my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end,$selfenroll) = @_; my $enrollresult; my $area = "/$cdom/$cnum"; if (($role ne 'cc') && ($role ne 'co') && ($sec ne '')) { @@ -801,220 +461,47 @@ sub enrolluser { $enrollresult = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef, undef,undef,$sec,$end,$start, - 'ltienroll',undef,$cdom.'_'.$cnum,undef, - 'ltienroll','',$instcid); + 'ltienroll',undef,$cdom.'_'.$cnum, + $selfenroll,'ltienroll','',$instcid); } elsif ($role =~ /^(cc|in|ta|ep)$/) { $enrollresult = &Apache::lonnet::assignrole($udom,$uname,$area,$role,$end,$start, - undef,undef,'ltienroll'); - } - return $enrollresult; -} - -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); - } + undef,$selfenroll,'ltienroll'); } - 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(); - } - } + if ($enrollresult eq 'ok') { + if ($selfenroll) { + my (%userroles,%newrole,%newgroups); + &Apache::lonnet::standard_roleprivs(\%newrole,$role,$cdom,$spec,$cnum, + $area); + &Apache::lonnet::set_userprivs(\%userroles,\%newrole,\%newgroups); + $userroles{'user.role.'.$spec} = $start.'.'.$end; + &Apache::lonnet::appenv(\%userroles,[$role,'cm']); } } - return; + return $enrollresult; } +# +# LON-CAPA as LTI Provider +# +# Gather a list of available LON-CAPA roles derived +# from a comma separated list of LTI roles. +# +# Which LON-CAPA roles are assignable by the current user +# and how LTI roles map to LON-CAPA roles (as defined in +# the domain configuration for the specific Consumer) are +# factored in when compiling the list of available roles. +# +# Inputs: 3 +# $rolestr - comma separated list of LTI roles. +# $allowedroles - reference to array of assignable LC roles +# $maproles - ref to HASH of mapping of LTI roles to LC roles +# +# Outputs: 2 +# (a) reference to array of available LC roles. +# (b) reference to array of LTI roles. +# + sub get_lc_roles { my ($rolestr,$allowedroles,$maproles) = @_; my (@ltiroles,@lcroles); @@ -1055,66 +542,4 @@ sub get_lc_roles { return (\@lcroles,\@ltiroles); } -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; -} - -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; 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.