--- loncom/lti/ltiutils.pm 2018/04/17 14:03:01 1.8 +++ loncom/lti/ltiutils.pm 2018/08/12 02:24:42 1.13 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Utility functions for managing LON-CAPA LTI interactions # -# $Id: ltiutils.pm,v 1.8 2018/04/17 14:03:01 raeburn Exp $ +# $Id: ltiutils.pm,v 1.13 2018/08/12 02:24:42 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -34,6 +34,12 @@ 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); # @@ -324,6 +330,7 @@ sub sign_params { if ($sigmethod eq '') { $sigmethod = 'HMAC-SHA1'; } + 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( consumer_key => $key, @@ -473,36 +480,48 @@ sub release_tool_lock { # sub lti_provider_scope { - my ($tail,$cdom,$cnum) = @_; - my ($scope,$realuri); - if ($tail =~ m{^/uploaded/$cdom/$cnum/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) { + my ($tail,$cdom,$cnum,$getunenc) = @_; + my ($scope,$realuri,$passkey,$unencsymb); + if ($tail =~ m{^/?uploaded/$cdom/$cnum/(?:default|supplemental)(?:|_\d+)\.(?:sequence|page)(|___\d+___.+)$}) { my $rest = $1; if ($rest eq '') { $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; + $realuri .= '?symb='.$symb; + $passkey = $symb; + if ($getunenc) { + $unencsymb = $symb; + } } } - } elsif ($tail =~ m{^/res/$match_domain/$match_username/.+\.(?:sequence|page)(|___\d+___.+)$}) { + } elsif ($tail =~ m{^/?res/$match_domain/$match_username/.+\.(?:sequence|page)(|___\d+___.+)$}) { my $rest = $1; if ($rest eq '') { $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; + $realuri .= '?symb='.$symb; + $passkey = $symb; + if ($getunenc) { + $unencsymb = $symb; + } } } } elsif ($tail =~ m{^/tiny/$cdom/(\w+)$}) { @@ -527,6 +546,7 @@ sub lti_provider_scope { } else { $scope = 'resource'; } + $passkey = $symb; if ((&Apache::lonnet::EXT('resource.0.encrypturl',$symb) =~ /^yes$/i) && (!$env{'request.role.adv'})) { $realuri = &Apache::lonenc::encrypted(&Apache::lonnet::clutter($url)); @@ -539,12 +559,701 @@ sub lti_provider_scope { $realuri .= '?symb='.$symb; } } + if ($getunenc) { + $unencsymb = $symb; + } } - } elsif ($tail =~ m{^/$cdom/$cnum$}) { + } elsif (($tail =~ m{^/$cdom/$cnum$}) || ($tail eq '')) { $scope = 'course'; $realuri = '/adm/navmaps'; + $passkey = ''; + } + if ($scope eq 'map') { + $passkey = $realuri; + } + if (wantarray) { + return ($scope,$realuri,$unencsymb); + } else { + return $passkey; + } +} + +# +# 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"], + ); + $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 ($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, + $curr_rules,$got_rules) = @_; + return unless (ref($ltiref) eq 'HASH'); + my $checkhash = { "$uname:$udom" => { 'newuser' => 1, }, }; + my $checks = { 'username' => 1, }; + my ($lcauth,$lcauthparm); + &Apache::loncommon::user_rule_check($checkhash,$checks,$alerts,$rulematch, + $inst_results,$curr_rules,$got_rules); + my ($userchkmsg,$lcauth,$lcauthparm); + my $allowed = 1; + if (ref($alerts->{'username'}) eq 'HASH') { + if (ref($alerts->{'username'}{$udom}) eq 'HASH') { + if ($alerts->{'username'}{$udom}{$uname}) { + if (ref($curr_rules->{$udom}) eq 'HASH') { + $userchkmsg = + &Apache::loncommon::instrule_disallow_msg('username',$domdesc,1). + &Apache::loncommon::user_rule_formats($udom,$domdesc, + $curr_rules->{$udom}{'username'}, + 'username'); + } + $allowed = 0; + } + } + } + if ($allowed) { + if (ref($rulematch->{$uname.':'.$udom}) eq 'HASH') { + my $matchedrule = $rulematch->{$uname.':'.$udom}{'username'}; + my ($rules,$ruleorder) = + &Apache::lonnet::inst_userrules($udom,'username'); + if (ref($rules) eq 'HASH') { + if (ref($rules->{$matchedrule}) eq 'HASH') { + $lcauth = $rules->{$matchedrule}{'authtype'}; + $lcauthparm = $rules->{$matchedrule}{'authparm'}; + } + } + } + if ($lcauth eq '') { + $lcauth = $ltiref->{'lcauth'}; + if ($lcauth eq 'internal') { + $lcauthparm = &create_passwd(); + } else { + $lcauthparm = $ltiref->{'lcauthparm'}; + } + } + } else { + return 'notallowed'; + } + my @userinfo = ('firstname','middlename','lastname','generation','permanentemail','id'); + my (%useinstdata,%info); + if (ref($ltiref->{'instdata'}) eq 'ARRAY') { + map { $useinstdata{$_} = 1; } @{$ltiref->{'instdata'}}; + } + foreach my $item (@userinfo) { + if (($useinstdata{$item}) && (ref($inst_results->{$uname.':'.$udom}) eq 'HASH') && + ($inst_results->{$uname.':'.$udom}{$item} ne '')) { + $info{$item} = $inst_results->{$uname.':'.$udom}{$item}; + } else { + if ($item eq 'permanentemail') { + if ($data->{'permanentemail'} =~/^[^\@]+\@[^@]+$/) { + $info{$item} = $data->{'permanentemail'}; + } + } elsif (($item eq 'firstname') || ($item eq 'lastname')) { + $info{$item} = $data->{$item}; + } + } + } + if (($info{'middlename'} eq '') && ($data->{'fullname'} ne '')) { + unless ($useinstdata{'middlename'}) { + my $fullname = $data->{'fullname'}; + if ($info{'firstname'}) { + $fullname =~ s/^\s*\Q$info{'firstname'}\E\s*//i; + } + if ($info{'lastname'}) { + $fullname =~ s/\s*\Q$info{'lastname'}\E\s*$//i; + } + if ($fullname ne '') { + $fullname =~ s/^\s+|\s+$//g; + if ($fullname ne '') { + $info{'middlename'} = $fullname; + } + } + } + } + if (ref($inst_results->{$uname.':'.$udom}{'inststatus'}) eq 'ARRAY') { + my @inststatuses = @{$inst_results->{$uname.':'.$udom}{'inststatus'}}; + $info{'inststatus'} = join(':',map { &escape($_); } @inststatuses); + } + my $result = + &Apache::lonnet::modifyuser($udom,$uname,$info{'id'}, + $lcauth,$lcauthparm,$info{'firstname'}, + $info{'middlename'},$info{'lastname'}, + $info{'generation'},undef,undef, + $info{'permanentemail'},$info{'inststatus'}); + 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)); + my $item = ''; + if ($lettnum) { + $item = $letts[int(rand(26))]; + my $uppercase = int(rand(2)); + if ($uppercase) { + $item =~ tr/a-z/A-Z/; + } + } else { + $item = int(rand(10)); + } + $passwd .= $item; + } + 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,$selfenroll) = @_; + my $enrollresult; + my $area = "/$cdom/$cnum"; + if (($role ne 'cc') && ($role ne 'co') && ($sec ne '')) { + $area .= '/'.$sec; + } + my $spec = $role.'.'.$area; + my $instcid; + if ($role eq 'st') { + $enrollresult = + &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef, + undef,undef,$sec,$end,$start, + 'ltienroll',undef,$cdom.'_'.$cnum, + $selfenroll,'ltienroll','',$instcid); + } elsif ($role =~ /^(cc|in|ta|ep)$/) { + $enrollresult = + &Apache::lonnet::assignrole($udom,$uname,$area,$role,$end,$start, + undef,$selfenroll,'ltienroll'); + } + 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 $enrollresult; +} + +# +# 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. +# +# 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); + my @ltiroleorder = ('Instructor','TeachingAssistant','Mentor','Learner'); + if ($rolestr =~ /,/) { + my @possltiroles = split(/\s*,\s*/,$rolestr); + foreach my $ltirole (@ltiroleorder) { + if (grep(/^\Q$ltirole\E$/,@possltiroles)) { + push(@ltiroles,$ltirole); + } + } + } else { + my $singlerole = $rolestr; + $singlerole =~ s/^\s|\s+$//g; + if ($singlerole ne '') { + if (grep(/^\Q$singlerole\E$/,@ltiroleorder)) { + @ltiroles = ($singlerole); + } + } + } + if (@ltiroles) { + my %possroles; + map { $possroles{$maproles->{$_}} = 1; } @ltiroles; + if (keys(%possroles) > 0) { + if (ref($allowedroles) eq 'ARRAY') { + foreach my $item (@{$allowedroles}) { + if (($item eq 'co') || ($item eq 'cc')) { + if ($possroles{'cc'}) { + push(@lcroles,$item); + } + } elsif ($possroles{$item}) { + push(@lcroles,$item); + } + } + } + } + } + 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 ($scope,$realuri); + return ($pbnum,$error); } 1;