--- loncom/lonnet/perl/lonnet.pm 2023/01/23 18:12:09 1.1172.2.146.2.12 +++ loncom/lonnet/perl/lonnet.pm 2023/07/09 00:49:22 1.1172.2.146.2.13 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.146.2.12 2023/01/23 18:12:09 raeburn Exp $ +# $Id: lonnet.pm,v 1.1172.2.146.2.13 2023/07/09 00:49:22 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -365,6 +365,63 @@ sub remote_devalidate_cache { return &reply('devalidatecache:'.&escape($cachestr),$lonhost); } +sub sign_lti { + my ($cdom,$cnum,$crsdef,$type,$context,$url,$ltinum,$keynum,$paramsref,$inforef) = @_; + my $chome; + if (&domain($cdom) ne '') { + if ($crsdef) { + $chome = &homeserver($cnum,$cdom); + } else { + $chome = &domain($cdom,'primary'); + } + } + if ($cdom && $chome && ($chome ne 'no_host')) { + if ((ref($paramsref) eq 'HASH') && + (ref($inforef) eq 'HASH')) { + my $rep; + if (grep { $_ eq $chome } ¤t_machine_ids()) { + # domain information is hosted on this machine + $rep = + &LONCAPA::Lond::sign_lti_payload($cdom,$cnum,$crsdef,$type, + $context,$url,$ltinum,$keynum, + $perlvar{'lonVersion'}, + $paramsref,$inforef); + if (ref($rep) eq 'HASH') { + return ('ok',$rep); + } + } else { + my ($escurl,$params,$info); + $escurl = &escape($url); + if (ref($paramsref) eq 'HASH') { + $params = &freeze_escape($paramsref); + } + if (ref($inforef) eq 'HASH') { + $info = &freeze_escape($inforef); + } + $rep=&reply("encrypt:signlti:$cdom:$cnum:$crsdef:$type:$context:$escurl:$ltinum:$keynum:$params:$info",$chome); + } + if (($rep eq '') || ($rep =~ /^con_lost|error|no_such_host|unknown_cmd/i)) { + return (); + } elsif (($inforef->{'respfmt'} eq 'to_post_body') || + ($inforef->{'respfmt'} eq 'to_authorization_header')) { + return ('ok',$rep); + } else { + my %returnhash; + foreach my $item (split(/\&/,$rep)) { + my ($name,$value)=split(/\=/,$item); + $returnhash{&unescape($name)}=&thaw_unescape($value); + } + return('ok',\%returnhash); + } + } else { + return (); + } + } else { + return (); + &logthis("sign_lti failed - no homeserver and/or domain ($cdom) ($chome)"); + } +} + # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; @@ -418,14 +475,15 @@ sub reply { my $subcmd = $1; if (($subcmd eq 'auth') || ($subcmd eq 'passwd') || ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || - ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) { + ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades') || + ($subcmd eq 'put')) { (undef,undef,my @rest) = split(/:/,$cmd); if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) { splice(@rest,2,1,'Hidden'); } elsif ($subcmd eq 'passwd') { splice(@rest,2,2,('Hidden','Hidden')); } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || - ($subcmd eq 'autoexportgrades')) { + ($subcmd eq 'autoexportgrades') || ($subcmd eq 'put')) { splice(@rest,3,1,'Hidden'); } $logged = join(':',('encrypt:'.$subcmd,@rest)); @@ -694,6 +752,11 @@ sub check_for_valid_session { if ($disk_env{'request.role'}) { $userhashref->{'role'} = $disk_env{'request.role'}; } + $userhashref->{'lti'} = $disk_env{'request.lti.login'}; + if ($userhashref->{'lti'}) { + $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; + $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'}; + } } untie(%disk_env); @@ -1035,6 +1098,20 @@ sub find_existing_session { return; } +sub delusersession { + my ($lonid,$udom,$uname) = @_; + my $uprimary_id = &domain($udom,'primary'); + my $uintdom = &internet_dom($uprimary_id); + my $intdom = &internet_dom($lonid); + my $serverhomedom = &host_domain($lonid); + if (($uintdom ne '') && ($uintdom eq $intdom)) { + return &reply(join(':','delusersession', + map {&escape($_)} ($udom,$uname)),$lonid); + } + return; +} + + # check if user's browser sent load balancer cookie and server still has session # and is not overloaded. sub check_for_balancer_cookie { @@ -2435,7 +2512,9 @@ sub get_domain_defaults { 'coursedefaults','usersessions', 'requestauthor','selfenrollment', 'coursecategories','autoenroll', - 'helpsettings','wafproxy','ltisec'],$domain); + 'helpsettings','wafproxy','ltisec', + 'toolsec','domexttool','exttool'], + $domain); my @coursetypes = ('official','unofficial','community','textbook'); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; @@ -2506,6 +2585,16 @@ sub get_domain_defaults { $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; } } + if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') { + $domdefaults{$type.'domexttool'} = $domconfig{'coursedefaults'}{'domexttool'}{$type}; + } else { + $domdefaults{$type.'domexttool'} = 1; + } + if (ref($domconfig{'coursedefaults'}{'exttool'}) eq 'HASH') { + $domdefaults{$type.'exttool'} = $domconfig{'coursedefaults'}{'exttool'}{$type}; + } else { + $domdefaults{$type.'exttool'} = 0; + } } if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') { if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') { @@ -2601,7 +2690,18 @@ sub get_domain_defaults { } if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') { if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') { - $domdefaults{'privhosts'} = $domconfig{'ltisec'}{'private'}{'keys'}; + $domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'}; + } + } + } + if (ref($domconfig{'toolsec'}) eq 'HASH') { + if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') { + $domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'}; + $domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'}; + } + if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') { + if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') { + $domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'private'}{'keys'}; } } } @@ -3987,7 +4087,7 @@ sub resizeImage { # input: $formname - the contents of the file are in $env{"form.$formname"} # the desired filename is in $env{"form.$formname.filename"} # $context - possible values: coursedoc, existingfile, overwrite, -# canceloverwrite, scantron or ''. +# canceloverwrite, scantron, toollogo or ''. # if 'coursedoc': upload to the current course # if 'existingfile': write file to tmp/overwrites directory # if 'canceloverwrite': delete file written to tmp/overwrites directory @@ -3999,8 +4099,8 @@ sub resizeImage { # Section => 4, CODE => 5, FirstQuestion => 9 }). # $allfiles - reference to hash for embedded objects # $codebase - reference to hash for codebase of java objects -# $desuname - username for permanent storage of uploaded file -# $dsetudom - domain for permanaent storage of uploaded file +# $destuname - username for permanent storage of uploaded file +# $destudom - domain for permanaent storage of uploaded file # $thumbwidth - width (pixels) of thumbnail to make for uploaded image # $thumbheight - height (pixels) of thumbnail to make for uploaded image # $resizewidth - width (pixels) to which to resize uploaded image @@ -4210,11 +4310,24 @@ sub finishuserfileupload { if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { my $input = $filepath.'/'.$file; my $output = $filepath.'/'.'tn-'.$file; + my $makethumb; my $thumbsize = $thumbwidth.'x'.$thumbheight; - my @args = ('convert','-sample',$thumbsize,$input,$output); - system({$args[0]} @args); - if (-e $filepath.'/'.'tn-'.$file) { - $fetchthumb = 1; + if ($context eq 'toollogo') { + my ($fullwidth,$fullheight) = &check_dimensions($input); + if ($fullwidth ne '' && $fullheight ne '') { + if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) { + $makethumb = 1; + } + } + } else { + $makethumb = 1; + } + if ($makethumb) { + my @args = ('convert','-sample',$thumbsize,$input,$output); + system({$args[0]} @args); + if (-e $filepath.'/'.'tn-'.$file) { + $fetchthumb = 1; + } } } @@ -4446,6 +4559,30 @@ sub embedded_dependency { return; } +sub check_dimensions { + my ($inputfile) = @_; + my ($fullwidth,$fullheight); + if (($inputfile =~ m|^[/\w.\-]+$|) && (-e $inputfile)) { + my $mm = new File::MMagic; + my $mime_type = $mm->checktype_filename($inputfile); + if ($mime_type =~ m{^image/}) { + if (open(PIPE,"identify $inputfile 2>&1 |")) { + my $imageinfo = ; + if (!close(PIPE)) { + &Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile"); + } + chomp($imageinfo); + my ($fullsize) = + ($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/); + if ($fullsize) { + ($fullwidth,$fullheight) = split(/x/,$fullsize); + } + } + } + } + return ($fullwidth,$fullheight); +} + sub bubblesheet_converter { my ($cdom,$fullpath,$config,$format) = @_; if ((&domain($cdom) ne '') && @@ -4809,7 +4946,7 @@ sub flushcourselogs { # Typo in rev. 1.458 (2003/12/09)?? # These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'} # -# While these ramain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'} +# While these remain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'} # $dom and $name will always be null, so the &inc() call will default to storing this data # in a nohist_accesscount.db file for the user rather than the course. # @@ -7758,6 +7895,17 @@ sub is_portfolio_file { return; } +sub is_coursetool_logo { + my ($uri) = @_; + if ($env{'request.course.id'}) { + my $courseurl = &courseid_to_courseurl($env{'request.course.id'}); + if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) { + return 1; + } + } + return; +} + sub usertools_access { my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_; my ($access,%tools); @@ -7770,6 +7918,7 @@ sub usertools_access { unofficial => 1, community => 1, textbook => 1, + lti => 1, ); } elsif ($context eq 'requestauthor') { %tools = ( @@ -7967,25 +8116,29 @@ sub is_advanced_user { } sub check_can_request { - my ($dom,$can_request,$request_domains) = @_; + my ($dom,$can_request,$request_domains,$uname,$udom) = @_; my $canreq = 0; + if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { + $uname = $env{'user.name'}; + $udom = $env{'user.domain'}; + } my ($types,$typename) = &Apache::loncommon::course_types(); my @options = ('approval','validate','autolimit'); my $optregex = join('|',@options); if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { foreach my $type (@{$types}) { - if (&usertools_access($env{'user.name'}, - $env{'user.domain'}, - $type,undef,'requestcourses')) { + if (&usertools_access($uname,$udom,$type,undef, + 'requestcourses')) { $canreq ++; if (ref($request_domains) eq 'HASH') { - push(@{$request_domains->{$type}},$env{'user.domain'}); + push(@{$request_domains->{$type}},$udom); } - if ($dom eq $env{'user.domain'}) { + if ($dom eq $udom) { $can_request->{$type} = 1; } } - if ($env{'environment.reqcrsotherdom.'.$type} ne '') { + if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') && + ($env{'environment.reqcrsotherdom.'.$type} ne '')) { my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type}); if (@curr > 0) { foreach my $item (@curr) { @@ -8002,7 +8155,7 @@ sub check_can_request { } } } - unless($dom eq $env{'user.domain'}) { + unless ($dom eq $env{'user.domain'}) { $canreq ++; if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) { $can_request->{$type} = 1; @@ -8374,6 +8527,12 @@ sub allowed { if ($env{'request.course.id'}) { + if ($priv eq 'bre') { + if (&is_coursetool_logo($uri)) { + return 'F'; + } + } + # If this is modifying password (internal auth) domains must match for user and user's role. if ($priv eq 'mip') { @@ -10182,8 +10341,12 @@ sub assignrole { } } } - } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { - $refused = ''; + } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + if ($role eq 'st') { + $refused = ''; + } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) { + $refused = ''; + } } elsif ($context eq 'requestcourses') { my @possroles = ('st','ta','ep','in','cc','co'); if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { @@ -10475,10 +10638,14 @@ sub modifyuser { my $newuser; if ($uhome eq 'no_host') { $newuser = 1; + unless (($umode && ($upass ne '')) || ($umode eq 'localauth') || + ($umode eq 'lti')) { + return 'error: more information needed to create new user'; + } } # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && - (($umode && $upass) || ($umode eq 'localauth'))) { + (($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) { my $unhome=''; if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { $unhome = $desiredhome; @@ -11825,13 +11992,11 @@ sub get_domain_lti { } else { return %lti; } - if ($context eq 'linkprot') { $cachename = $context; } else { $cachename = $name; } - my ($result,$cached)=&is_cached_new($cachename,$cdom); if (defined($cached)) { if (ref($result) eq 'HASH') { @@ -11847,18 +12012,6 @@ sub get_domain_lti { } else { %lti = %{$domconfig{$name}}; } - if (($context eq 'consumer') && (keys(%lti))) { - my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1); - if (ref($encdomconfig{$name}) eq 'HASH') { - foreach my $id (keys(%lti)) { - if (ref($encdomconfig{$name}{$id}) eq 'HASH') { - foreach my $item ('key','secret') { - $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item}; - } - } - } - } - } } my $cachetime = 24*60*60; &do_cache_new($cachename,$cdom,\%lti,$cachetime); @@ -11867,20 +12020,29 @@ sub get_domain_lti { } sub get_course_lti { - my ($cnum,$cdom) = @_; + my ($cnum,$cdom,$context) = @_; + my ($name,$cachename,%lti); + if ($context eq 'consumer') { + $name = 'ltitools'; + $cachename = 'courseltitools'; + } elsif ($context eq 'provider') { + $name = 'lti'; + $cachename = 'courselti'; + } else { + return %lti; + } my $hashid=$cdom.'_'.$cnum; - my %courselti; - my ($result,$cached)=&is_cached_new('courselti',$hashid); + my ($result,$cached)=&is_cached_new($cachename,$hashid); if (defined($cached)) { if (ref($result) eq 'HASH') { - %courselti = %{$result}; + %lti = %{$result}; } } else { - %courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1); + %lti = &dump($name,$cdom,$cnum,undef,undef,undef,1); my $cachetime = 24*60*60; - &do_cache_new('courselti',$hashid,\%courselti,$cachetime); + &do_cache_new($cachename,$hashid,\%lti,$cachetime); } - return %courselti; + return %lti; } sub courselti_itemid { @@ -12258,20 +12420,25 @@ sub EXT { } # ------------------------------------------ fourth, look in resource metadata - $spacequalifierrest=~s/\./\_/; - my $filename; + my $what = $spacequalifierrest; + $what=~s/\./\_/; + my $filename; if (!$symbparm) { $symbparm=&symbread(); } if ($symbparm) { $filename=(&decode_symb($symbparm))[2]; } else { $filename=$env{'request.filename'}; } - my $metadata=&metadata($filename,$spacequalifierrest); + my $toolsymb; + if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) { + $toolsymb = $symbparm; + } + my $metadata=&metadata($filename,$what,$toolsymb); if (defined($metadata)) { return &get_reply([$metadata,'resource']); } - $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); + $metadata=&metadata($filename,'parameter_'.$what,$toolsymb); if (defined($metadata)) { return &get_reply([$metadata,'resource']); } -# ---------------------------------------------- fourth, look in rest of course +# ----------------------------------------------- fifth, look in rest of course if ($symbparm && defined($courseid) && $courseid eq $env{'request.course.id'}) { my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, @@ -12292,7 +12459,7 @@ sub EXT { if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } } if ($recurse) { return undef; } - my $pack_def=&packages_tab_default($filename,$varname); + my $pack_def=&packages_tab_default($filename,$varname,$toolsymb); if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { @@ -12385,11 +12552,11 @@ sub sort_course_groups { # Sort groups b } sub packages_tab_default { - my ($uri,$varname)=@_; + my ($uri,$varname,$toolsymb)=@_; my (undef,$part,$name)=split(/\./,$varname); my (@extension,@specifics,$do_default); - foreach my $package (split(/,/,&metadata($uri,'packages'))) { + foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) { my ($pack_type,$pack_part)=split(/_/,$package,2); if ($pack_type eq 'default') { $do_default=1; @@ -12458,7 +12625,7 @@ my %metaentry; my %importedpartids; my %importedrespids; sub metadata { - my ($uri,$what,$liburi,$prefix,$depthcount)=@_; + my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); # if it is a non metadata possible uri return quickly if (($uri eq '') || @@ -12482,6 +12649,65 @@ sub metadata { my ($result,$cached)=&is_cached_new('meta',$uri); if (defined($cached)) { return $result->{':'.$what}; } } + +# +# If the uri is for an external tool the file from +# which metadata should be retrieved depends on whether +# the tool had been configured to be gradable (set in the Course +# Editor or Resource Editor). +# +# If a valid symb has been included as the third arg in the call +# to &metadata() that can be used to retrieve the value of +# parameter_0_gradable set for the resource, and included in the +# uploaded map containing the tool. The value is retrieved via +# &EXT(), if a valid symb is available. Otherwise the value of +# gradable in the exttool_$marker.db file for the tool instance +# is retrieved via &get(). +# +# When lonuserstate::traceroute() calls lonnet::EXT() for +# hiddenresource and encrypturl (during course initialization) +# the map-level parameter for resource.0.gradable included in the +# uploaded map containing the tool will not yet have been stored +# in the user_course_parms.db file for the user's session, so in +# this case fall back to retrieving gradable status from the +# exttool_$marker.db file. +# +# In order to avoid an infinite loop, &metadata() will return +# before a call to &EXT(), if the uri is for an external tool +# and the $what for which metadata is being requested is +# parameter_0_gradable or 0_gradable. +# + + if ($uri =~ /ext\.tool$/) { + if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) { + return; + } else { + my ($checked,$use_passback); + if ($toolsymb ne '') { + (undef,undef,my $tooluri) = &decode_symb($toolsymb); + if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) { + $checked = 1; + if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) { + $use_passback = 1; + } + } + } + unless ($checked) { + my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri); + $marker=~s/\D//g; + if ($marker) { + my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum); + $use_passback = $toolsettings{'gradable'}; + } + } + if ($use_passback) { + $filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool'; + } else { + $filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool'; + } + } + } + { # Imported parts would go here my @origfiletagids=(); @@ -12655,7 +12881,7 @@ sub metadata { if ($depthcount<20) { my $metadata = - &metadata($uri,'keys', $location,$unikey, + &metadata($uri,'keys',$toolsymb,$location,$unikey, $depthcount+1); foreach my $meta (split(',',$metadata)) { $metaentry{':'.$meta}=$metaentry{':'.$meta}; @@ -12730,7 +12956,7 @@ sub metadata { $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); my $rights_metadata = - &metadata($uri,'keys',$location,'_rights', + &metadata($uri,'keys',$toolsymb,$location,'_rights', $depthcount+1); foreach my $rights (split(',',$rights_metadata)) { #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; @@ -15955,10 +16181,14 @@ condval($condidx) : value of condition i =item * -metadata($uri,$what,$liburi,$prefix,$depthcount) : request a +metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a resource's metadata, $what should be either a specific key, or either 'keys' (to get a list of possible keys) or 'packages' to get a list of -packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. +packages that this resource currently uses, the last 3 arguments are +only used internally for recursive metadata. + +the toolsymb is only used where the uri is for an external tool (for which +the uri as well as the symb are guaranteed to be unique). this function automatically caches all requests