--- loncom/lti/ltiutils.pm	2018/05/15 04:59:22	1.10
+++ loncom/lti/ltiutils.pm	2018/05/28 23:26:04	1.11
@@ -1,7 +1,7 @@
 # The LearningOnline Network with CAPA
 # Utility functions for managing LON-CAPA LTI interactions 
 #
-# $Id: ltiutils.pm,v 1.10 2018/05/15 04:59:22 raeburn Exp $
+# $Id: ltiutils.pm,v 1.11 2018/05/28 23:26:04 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -34,6 +34,10 @@ 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 Math::Round();
 use LONCAPA qw(:DEFAULT :match);
 
@@ -569,6 +573,64 @@ 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"],
+            );
+            $p->parse($response->content);
+            $p->eof;
+            return %data;
+        }
+    }
+    return;
+}
+
 sub send_grade {
     my ($id,$url,$ckey,$secret,$scoretype,$total,$possible) = @_;
     my $score;
@@ -609,4 +671,450 @@ sub send_grade {
     }
 }
 
+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;
+}
+
+sub create_passwd {
+    my $passwd = '';
+    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);
+}
+
+sub enrolluser {
+    my ($udom,$uname,$role,$cdom,$cnum,$sec,$start,$end) = @_;
+    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,undef,
+                                                       '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);
+        }
+    }
+    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;
+}
+
+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);
+}
+
+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;