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

Diff for /loncom/lti/ltiutils.pm between versions 1.2 and 1.14

version 1.2, 2017/12/09 16:24:03 version 1.14, 2018/08/14 17:24:21
Line 34  use Digest::SHA; Line 34  use Digest::SHA;
 use UUID::Tiny ':std';  use UUID::Tiny ':std';
 use Apache::lonnet;  use Apache::lonnet;
 use Apache::loncommon;  use Apache::loncommon;
   use Apache::loncoursedata;
   use Apache::lonuserutils;
   use Apache::lonenc();
   use Apache::longroup();
   use Apache::lonlocal;
   use Math::Round();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
   
 #  #
Line 51  use LONCAPA qw(:DEFAULT :match); Line 57  use LONCAPA qw(:DEFAULT :match);
 #  #
 # When LON-CAPA is operating as a Provider, nonce checking   # When LON-CAPA is operating as a Provider, nonce checking 
 # occurs when a user in course context in another LMS (the   # occurs when a user in course context in another LMS (the 
 # Consumer launches an external tool to access a LON-CAPA URL:   # Consumer) launches an external tool to access a LON-CAPA URL: 
 # /adm/lti/ with LON-CAPA symb, map, or deep-link ID appended.  # /adm/lti/ with LON-CAPA symb, map, or deep-link ID appended.
 #  #
   
Line 270  sub verify_lis_item { Line 276  sub verify_lis_item {
     my ($has_action, $valid_for);      my ($has_action, $valid_for);
     if ($context eq 'grade') {      if ($context eq 'grade') {
         $has_action = $ltitools->{'passback'};          $has_action = $ltitools->{'passback'};
         $valid_for = $ltitools->{'passbackvalid'}          $valid_for = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds
     } elsif ($context eq 'roster') {      } elsif ($context eq 'roster') {
         $has_action = $ltitools->{'roster'};          $has_action = $ltitools->{'roster'};
         $valid_for = $ltitools->{'rostervalid'};          $valid_for = $ltitools->{'rostervalid'};
Line 286  sub verify_lis_item { Line 292  sub verify_lis_item {
             my $expected_sig;              my $expected_sig;
             if ($context eq 'grade') {              if ($context eq 'grade') {
                 my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;                  my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;
                 $expected_sig = &get_service_id($secret,$uniqid);                  $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; 
                 if ($expected_sig eq $sigrec) {                  if ($expected_sig eq $sigrec) {
                     return 1;                      return 1;
                 } else {                  } else {
Line 294  sub verify_lis_item { Line 300  sub verify_lis_item {
                 }                  }
             } elsif ($context eq 'roster') {              } elsif ($context eq 'roster') {
                 my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;                  my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;
                 $expected_sig = &get_service_id($secret,$uniqid);                  $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; 
                 if ($expected_sig eq $sigrec) {                  if ($expected_sig eq $sigrec) {
                     return 1;                      return 1;
                 } else {                  } else {
Line 314  sub verify_lis_item { Line 320  sub verify_lis_item {
 # LON-CAPA as LTI Consumer  # LON-CAPA as LTI Consumer
 #  #
 # Sign a request used to launch an instance of an external  # Sign a request used to launch an instance of an external
 # too in a LON-CAPA course, using the key and secret supplied   # tool in a LON-CAPA course, using the key and secret supplied 
 # by the Tool Provider.  # by the Tool Provider.
 #   # 
   
 sub sign_params {  sub sign_params {
     my ($url,$key,$secret,$paramsref) = @_;      my ($url,$key,$secret,$sigmethod,$paramsref) = @_;
     return unless (ref($paramsref) eq 'HASH');      return unless (ref($paramsref) eq 'HASH');
       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 $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("request token")->new(
             consumer_key => $key,              consumer_key => $key,
             consumer_secret => $secret,              consumer_secret => $secret,
             request_url => $url,              request_url => $url,
             request_method => 'POST',              request_method => 'POST',
             signature_method => 'HMAC-SHA1',              signature_method => $sigmethod,
             timestamp => time,              timestamp => time,
             nonce => $nonce,              nonce => $nonce,
             callback => 'about:blank',              callback => 'about:blank',
Line 372  sub set_service_secret { Line 382  sub set_service_secret {
     my $warning;      my $warning;
     my ($needsnew,$oldsecret,$lifetime);      my ($needsnew,$oldsecret,$lifetime);
     if ($name eq 'grade') {      if ($name eq 'grade') {
         $lifetime = $ltitools->{'passbackvalid'}          $lifetime = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds
     } elsif ($name eq 'roster') {      } elsif ($name eq 'roster') {
         $lifetime = $ltitools->{'rostervalid'};          $lifetime = $ltitools->{'rostervalid'};
     }      }
     if ($toolsettings->{$name} eq '') {      if ($toolsettings->{$name.'secret'} eq '') {
         $needsnew = 1;          $needsnew = 1;
     } elsif (($toolsettings->{$name.'date'} + $lifetime) < $now) {      } elsif (($toolsettings->{$name.'secretdate'} + $lifetime) < $now) {
         $oldsecret = $toolsettings->{$name.'secret'};          $oldsecret = $toolsettings->{$name.'secret'};
         $needsnew = 1;          $needsnew = 1;
     }      }
Line 444  sub get_tool_lock { Line 454  sub get_tool_lock {
 #  #
   
 sub release_tool_lock {  sub release_tool_lock {
     my ($cdom,$cnum,$marker) = @_;      my ($cdom,$cnum,$marker,$name) = @_;
     #  remove lock      #  remove lock
     my @del_lock = ($name."\0".$marker."\0".'lock');      my @del_lock = ($name."\0".$marker."\0".'lock');
     my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum);      my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum);
Line 455  sub release_tool_lock { Line 465  sub release_tool_lock {
     }      }
 }  }
   
   #
   # LON-CAPA as LTI Provider
   #
   # Use the part of the launch URL after /adm/lti to determine
   # the scope for the current session (i.e., restricted to a
   # single resource, to a single folder/map, or to an entire
   # course).
   #
   # Returns an array containing scope: resource, map, or course
   # and the LON-CAPA URL that is displayed post-launch, including
   # accommodation of URL encryption, and translation of a tiny URL
   # to the actual URL
   #
   
   sub lti_provider_scope {
       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 $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='.$symb;
                   $passkey = $symb;
                   if ($getunenc) {
                       $unencsymb = $symb;
                   }
               }
           }
       } elsif ($tail =~ m{^/?res/$match_domain/$match_username/.+\.(?:sequence|page)(|___\d+___.+)$}) {
           my $rest = $1;
           if ($rest eq '') {
               $scope = 'map';
               $realuri = $tail;
           } else {
               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='.$symb;
                   $passkey = $symb;
                   if ($getunenc) {
                       $unencsymb = $symb;
                   }
               }
           }
       } elsif ($tail =~ m{^/tiny/$cdom/(\w+)$}) {
           my $key = $1;
           my $tinyurl;
           my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
           if (defined($cached)) {
               $tinyurl = $result;
           } else {
               my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
               my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
               if ($currtiny{$key} ne '') {
                   $tinyurl = $currtiny{$key};
                   &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
               }
           }
           if ($tinyurl ne '') {
               my ($cnum,$symb) = split(/\&/,$tinyurl,2);
               my ($map,$resid,$url) = &Apache::lonnet::decode_symb($symb);
               if ($url =~ /\.(page|sequence)$/) {
                   $scope = 'map';
               } 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));
                   if ($scope eq 'resource') {
                       $realuri .= '?symb='.&Apache::lonenc::encrypted($symb);
                   }
               } else {
                   $realuri = &Apache::lonnet::clutter($url);
                   if ($scope eq 'resource') {
                       $realuri .= '?symb='.$symb;
                   }
               }
               if ($getunenc) {
                   $unencsymb = $symb;
               }
           }
       } 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 ($pbnum,$error);
   }
   
 1;  1;
Removed from v.1.2  
changed lines
  Added in v.1.14

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
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.