# The LearningOnline Network with CAPA
# Utility functions for managing LON-CAPA LTI interactions 
#
# $Id: ltiutils.pm,v 1.17 2019/07/18 18:28:46 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#

package LONCAPA::ltiutils;

use strict;
use Net::OAuth;
use Digest::SHA;
use Digest::MD5 qw(md5_hex);
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);

#
# LON-CAPA as LTI Consumer or LTI Provider
#
# Determine if a nonce in POSTed data has expired.
# If unexpired, confirm it has not already been used.
#
# When LON-CAPA is operating as a Consumer, nonce checking
# occurs when a Tool Provider launched from an instance of
# an external tool in a LON-CAPA course makes a request to
# (a) /adm/service/roster or (b) /adm/service/passback to, 
# respectively, retrieve a roster or store the grade for 
# the original launch by a specific user.
#
# When LON-CAPA is operating as a Provider, nonce checking 
# occurs when a user in course context in another LMS (the 
# Consumer) launches an external tool to access a LON-CAPA URL: 
# /adm/lti/ with LON-CAPA symb, map, or deep-link ID appended.
#

sub check_nonce {
    my ($nonce,$timestamp,$lifetime,$domain,$ltidir) = @_;
    if (($ltidir eq '') || ($timestamp eq '') || ($timestamp =~ /^\D/) ||
        ($lifetime eq '') || ($lifetime =~ /\D/) || ($domain eq '')) {
        return;
    }
    my $now = time;
    if (($timestamp) && ($timestamp < ($now - $lifetime))) {
        return;
    }
    if ($nonce eq '') {
        return;
    }
    if (-e "$ltidir/$domain/$nonce") {
        return;
    } else  {
        unless (-e "$ltidir/$domain") {
            unless (mkdir("$ltidir/$domain",0755)) {
                return;
            }
        }
        if (open(my $fh,'>',"$ltidir/$domain/$nonce")) {
            print $fh $now;
            close($fh);
            return 1;
        }
    }
    return;
}

#
# 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 ($oauthtype,$protocol,$hostname,$requri,$reqmethod,$consumer_secret,$params,
        $authheaders,$errors) = @_;
    unless (ref($errors) eq 'HASH') {
        $errors->{15} = 1;
        return;
    }
    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 {
        $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;
    }
}

#
# LON-CAPA as LTI Consumer
#
# Verify that an item identifier (either roster request:
# ext_ims_lis_memberships_id, or grade store:
# lis_result_sourcedid) has not been tampered with, and
# the secret used to create the unique identifier has not
# expired.
#
# Prepending the current secret (if still valid),
# or the previous secret (if current one is no longer valid),
# to a string composed of the :::-separated components
# must generate the result signature in the lis item ID
# sent by the Tool Provider.
#

sub verify_lis_item {
    my ($sigrec,$context,$digsymb,$diguser,$cdom,$cnum,$toolsettings,$ltitools,$errors) = @_;
    return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH') && 
                   (ref($errors) eq 'HASH'));
    my ($has_action, $valid_for);
    if ($context eq 'grade') {
        $has_action = $ltitools->{'passback'};
        $valid_for = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds
    } elsif ($context eq 'roster') {
        $has_action = $ltitools->{'roster'};
        $valid_for = $ltitools->{'rostervalid'};
    }
    if ($has_action) {
        my $secret;
        if (($toolsettings->{$context.'secretdate'} + $valid_for) > time) {
            $secret = $toolsettings->{$context.'secret'};
        } else {
            $secret = $toolsettings->{'old'.$context.'secret'};
        }
        if ($secret) {
            my $expected_sig;
            if ($context eq 'grade') {
                my $uniqid = $digsymb.':::'.$diguser.':::'.$cdom.'_'.$cnum;
                $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; 
                if ($expected_sig eq $sigrec) {
                    return 1;
                } else {
                    $errors->{18} = 1;
                }
            } elsif ($context eq 'roster') {
                my $uniqid = $digsymb.':::'.$cdom.'_'.$cnum;
                $expected_sig = (split(/:::/,&get_service_id($secret,$uniqid)))[0]; 
                if ($expected_sig eq $sigrec) {
                    return 1;
                } else {
                    $errors->{19} = 1;
                }
            }
        } else {
            $errors->{20} = 1;
        }
    } else {
        $errors->{21} = 1;
    }
    return;
}

#
# LON-CAPA as LTI Consumer
#
# Sign a request used to launch an instance of an external
# tool in a LON-CAPA course, using the key and secret supplied 
# by the Tool Provider.
# 

sub sign_params {
    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($type)->new(
            consumer_key => $key,
            consumer_secret => $secret,
            request_url => $url,
            request_method => 'POST',
            signature_method => $sigmethod,
            timestamp => time,
            nonce => $nonce,
            callback => $callback,
            extra_params => $paramsref,
            version      => '1.0',
            );
    $request->sign();
    if ($post) {
        return $request->to_post_body();
    } else {
        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 old<service name>secret, and a new secret
# <service name>secret will be stored.
# 
# Secrets are specific to service name and to the tool instance 
# (and are stored in the exttool_$marker db file).
# The time period a secret remains valid is determined by the 
# domain configuration for the specific tool and the service.
# 

sub set_service_secret {
    my ($cdom,$cnum,$marker,$name,$now,$toolsettings,$ltitools) = @_;
    return unless ((ref($toolsettings) eq 'HASH') && (ref($ltitools) eq 'HASH'));
    my $warning;
    my ($needsnew,$oldsecret,$lifetime);
    if ($name eq 'grade') {
        $lifetime = $ltitools->{'passbackvalid'} * 86400; # convert days to seconds
    } elsif ($name eq 'roster') {
        $lifetime = $ltitools->{'rostervalid'};
    }
    if ($toolsettings->{$name.'secret'} eq '') {
        $needsnew = 1;
    } elsif (($toolsettings->{$name.'secretdate'} + $lifetime) < $now) {
        $oldsecret = $toolsettings->{$name.'secret'};
        $needsnew = 1;
    }
    if ($needsnew) {
        if (&get_tool_lock($cdom,$cnum,$marker,$name,$now) eq 'ok') {
            my $secret = UUID::Tiny::create_uuid_as_string(UUID_V4);
            $toolsettings->{$name.'secret'} = $secret;
            my %secrethash = (
                           $name.'secret' => $secret,
                           $name.'secretdate' => $now,
                          );
            if ($oldsecret ne '') {
                $secrethash{'old'.$name.'secret'} = $oldsecret;
            }
            my $putres = &Apache::lonnet::put('exttool_'.$marker,
                                              \%secrethash,$cdom,$cnum);
            my $delresult = &release_tool_lock($cdom,$cnum,$marker,$name);
            if ($delresult ne 'ok') {
                $warning = $delresult ;
            }
            if ($putres eq 'ok') {
                return 'ok';
            }
        } else {
            $warning = 'Could not obtain exclusive lock';
        }
    } else {
        return 'ok';
    }
    return;
}

#
# LON-CAPA as LTI Consumer
#
# Add a lock key to exttools.db for the instance of an external tool 
# when generating and storing a service secret.
#

sub get_tool_lock {
    my ($cdom,$cnum,$marker,$name,$now) = @_;
    # get lock for tool for which secret is being set
    my $lockhash = {
                     $name."\0".$marker."\0".'lock' => $now.':'.$env{'user.name'}.
                                                       ':'.$env{'user.domain'},
                   };
    my $tries = 0;
    my $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum);

    while (($gotlock ne 'ok') && $tries <3) {
        $tries ++;
        sleep(1);
        $gotlock = &Apache::lonnet::newput('exttools',$lockhash,$cdom,$cnum);
    }
    return $gotlock;
}

#
# LON-CAPA as LTI Consumer
#
# Remove a lock key from exttools.db for the instance of an external
# tool created when generating and storing a service secret.
#

sub release_tool_lock {
    my ($cdom,$cnum,$marker,$name) = @_;
    #  remove lock
    my @del_lock = ($name."\0".$marker."\0".'lock');
    my $dellockoutcome=&Apache::lonnet::del('exttools',\@del_lock,$cdom,$cnum);
    if ($dellockoutcome ne 'ok') {
        return 'Warning: failed to release lock for exttool';
    } else {
        return 'ok';
    }
}

#
# LON-CAPA as LTI Consumer
#
# Parse XML containing grade data sent by an LTI Provider
#

sub parse_grade_xml {
    my ($xml) = @_;
    my %data = ();
    my $count = 0;
    my @state = ();
    my $p = HTML::Parser->new(
        xml_mode => 1,
        start_h =>
            [sub {
                my ($tagname, $attr) = @_;
                push(@state,$tagname);
                if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord") {
                    $count ++;
                }
            }, "tagname, attr"],
        text_h =>
            [sub {
                my ($text) = @_;
                if ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord sourcedGUID sourcedId") {
                    $data{$count}{sourcedid} = $text;
                } elsif ("@state" eq "imsx_POXEnvelopeRequest imsx_POXBody replaceResultRequest resultRecord result resultScore textString") {                               
                    $data{$count}{score} = $text;
                }
            }, "dtext"],
        end_h =>
            [sub {
                 my ($tagname) = @_;
                 pop @state;
                }, "tagname"],
    );
    $p->parse($xml);
    $p->eof;
    return %data;
}

#
# LON-CAPA as LTI Provider
#
# Use the part of the launch URL after /adm/lti to determine
# 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,$sigmethod,$msgformat,$total,$possible) = @_;
    my $score;
    if ($possible > 0) {
        if ($scoretype eq 'ratio') {
            $score = Math::Round::round($total).'/'.Math::Round::round($possible);
        } elsif ($scoretype eq 'percentage') {
            $score = (100.0*$total)/$possible;
            $score = Math::Round::round($score);
        } else {
            $score = $total/$possible;
            $score = sprintf("%.2f",$score);
        }
    }
    if ($sigmethod eq '') {
        $sigmethod = 'HMAC-SHA1';
    }
    my $request;
    if ($msgformat eq '1.0') {
        my $date = &Apache::loncommon::utc_string(time);
        my %ltiparams = (
            lti_version                   => 'LTI-1p0',
            lti_message_type              => 'basic-lis-updateresult',
            sourcedid                     => $id,
            result_resultscore_textstring => $score,
            result_resultscore_language   => 'en-US',
            result_resultvaluesourcedid   => $scoretype,
            result_statusofresult         => 'final',
            result_date                   => $date,
        );
        my $hashref = &sign_params($url,$ckey,$secret,\%ltiparams,$sigmethod);
        if (ref($hashref) eq 'HASH') {
            $request=new HTTP::Request('POST',$url);
            $request->content(join('&',map {
                              my $name = escape($_);
                              "$name=" . ( ref($hashref->{$_}) eq 'ARRAY'
                              ? join("&$name=", map {escape($_) } @{$hashref->{$_}})
                              : &escape($hashref->{$_}) );
                              } keys(%{$hashref})));
        }
    } else {
        srand( time() ^ ($$ + ($$ << 15))  ); # Seed rand.
        my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));
        my $uniqmsgid = int(rand(2**32));
        my $gradexml = <<END;
<?xml version = "1.0" encoding = "UTF-8"?>
<imsx_POXEnvelopeRequest xmlns = "http://www.imsglobal.org/services/ltiv1p1/xsd/imsoms_v1p0">
  <imsx_POXHeader>
    <imsx_POXRequestHeaderInfo>
      <imsx_version>V1.0</imsx_version>
      <imsx_messageIdentifier>$uniqmsgid</imsx_messageIdentifier>
    </imsx_POXRequestHeaderInfo>
  </imsx_POXHeader>
  <imsx_POXBody>
    <replaceResultRequest>
      <resultRecord>
	<sourcedGUID>
	  <sourcedId>$id</sourcedId>
	</sourcedGUID>
	<result>
	  <resultScore>
	    <language>en</language>
	    <textString>$score</textString>
	  </resultScore>
	</result>
      </resultRecord>
    </replaceResultRequest>
  </imsx_POXBody>
</imsx_POXEnvelopeRequest>
END
        chomp($gradexml);
        my $bodyhash = Digest::SHA::sha1_base64($gradexml);
        while (length($bodyhash) % 4) {
            $bodyhash .= '=';
        }
        my $gradereq = Net::OAuth->request('consumer')->new(
                           consumer_key => $ckey,
                           consumer_secret => $secret,
                           request_url => $url,
                           request_method => 'POST',
                           signature_method => $sigmethod,
                           timestamp => time(),
                           nonce => $nonce,
                           body_hash => $bodyhash,
        );
        $gradereq->add_required_message_params('body_hash');
        $gradereq->sign();
        $request = HTTP::Request->new(
	               $gradereq->request_method,
	               $gradereq->request_url,
	               [
		           'Authorization' => $gradereq->to_authorization_header,
		           'Content-Type'  => 'application/xml',
	               ],
	               $gradexml,
        );
    }
    my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
    my $message=$response->status_line;
#FIXME Handle case where pass back of score to LTI Consumer failed.
}

sub setup_logout_callback {
    my ($uname,$udom,$server,$ckey,$secret,$service_url,$idsdir,$protocol,$hostname) = @_;
    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,
            );
            my $post = &sign_params($service_url,$ckey,$secret,\%ltiparams,
                                    '','','',1);
            my $request=new HTTP::Request('POST',$service_url);
            $request->content($post);
            my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10);
        }
    }
    return;
}

#
# 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;