Annotation of loncom/Lond.pm, revision 1.8.2.3.2.5
1.1 droeschl 1: # The LearningOnline Network
2: #
1.8.2.3.2.5! raeburn 3: # $Id: Lond.pm,v 1.8.2.3.2.4 2023/07/05 21:47:51 raeburn Exp $
1.1 droeschl 4: #
5: # Copyright Michigan State University Board of Trustees
6: #
7: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
8: #
9: # LON-CAPA is free software; you can redistribute it and/or modify
10: # it under the terms of the GNU General Public License as published by
11: # the Free Software Foundation; either version 2 of the License, or
12: # (at your option) any later version.
13: #
14: # LON-CAPA is distributed in the hope that it will be useful,
15: # but WITHOUT ANY WARRANTY; without even the implied warranty of
16: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17: # GNU General Public License for more details.
18: #
19: # You should have received a copy of the GNU General Public License
20: # along with LON-CAPA; if not, write to the Free Software
21: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22: #
23: # /home/httpd/html/adm/gpl.txt
24: #
25: # http://www.lon-capa.org/
26: #
27: ###
28:
29: #NOTE perldoc at the end of file
1.4 droeschl 30: #TODO move remaining lond functions into this
1.1 droeschl 31:
32: package LONCAPA::Lond;
33:
34: use strict;
35: use lib '/home/httpd/lib/perl/';
36:
37: use LONCAPA;
38: use Apache::lonnet;
39: use GDBM_File;
1.8.2.3.2.1 raeburn 40: use Net::OAuth;
1.8.2.3.2.3 raeburn 41: use Crypt::CBC;
1.8.2.3.2.4 raeburn 42: use Digest::SHA;
43: use Digest::MD5 qw(md5_hex);
1.1 droeschl 44:
45: sub dump_with_regexp {
1.4 droeschl 46: my ( $tail, $clientversion ) = @_;
1.2 droeschl 47: my ( $udom, $uname, $namespace, $regexp, $range ) =
48: split /:/, $tail;
1.1 droeschl 49:
1.4 droeschl 50: $regexp = $regexp ? unescape($regexp) : '.';
1.1 droeschl 51:
52: my ($start,$end);
1.2 droeschl 53:
1.1 droeschl 54: if (defined($range)) {
1.2 droeschl 55: if ($range =~ /^(\d+)\-(\d+)$/) {
56: ($start,$end) = ($1,$2);
57: } elsif ($range =~/^(\d+)$/) {
58: ($start,$end) = (0,$1);
59: } else {
60: undef($range);
61: }
62: }
63:
1.8.2.3.2.5! raeburn 64: #
! 65: # If dump is for file_permissions.db from a pre-2.12 server and
! 66: # $uname:$udom is not a course, determine if value of portaccess
! 67: # in effect for $uname:$udom allows portfolio files to be shared.
! 68: # If sharing is not allowed, records returned for accesscontrol
! 69: # are restricted to those based on ip (i.e., for externalresponse).
! 70: #
! 71: # Note: for 2.12 or later session-hosting server, determination
! 72: # of portaccess value in effect occurs client-side.
! 73: #
! 74: my ($check_portaccess,$access,$now,$major,$minor,%by_ip);
! 75: if ($namespace eq 'file_permissions') {
! 76: if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
! 77: $major = $1;
! 78: $minor = $2;
! 79: }
! 80: unless ((($major > 2) || (($major == 2) && ($minor > 11))) ||
! 81: &is_course($udom,$uname)) {
! 82: $check_portaccess = 1;
! 83: $access = &portfolio_is_shareable($udom,$uname);
! 84: }
! 85: $now = time;
! 86: }
! 87:
1.2 droeschl 88: my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or
89: return "error: ".($!+0)." tie(GDBM) Failed while attempting dump";
90:
91: my $qresult = '';
92: my $count = 0;
1.1 droeschl 93: #
94: # When dump is for roles.db, determine if LON-CAPA version checking is needed.
1.2 droeschl 95: # Sessions on 2.10 and later do not require version checking, as that occurs
1.1 droeschl 96: # on the server hosting the user session, when constructing the roles/courses
97: # screen).
98: #
1.2 droeschl 99: my $skipcheck;
100: my @ids = &Apache::lonnet::current_machine_ids();
1.8.2.3.2.5! raeburn 101: my %homecourses;
1.1 droeschl 102: #
103: # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA
1.2 droeschl 104: # version on the server which requested the data.
1.1 droeschl 105: #
1.2 droeschl 106: if ($namespace eq 'roles') {
107: if ($clientversion =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
108: $major = $1;
109: $minor = $2;
1.4 droeschl 110:
1.2 droeschl 111: }
112: if (($major > 2) || (($major == 2) && ($minor > 9))) {
113: $skipcheck = 1;
1.1 droeschl 114: }
1.2 droeschl 115: $now = time;
116: }
117: while (my ($key,$value) = each(%$hashref)) {
118: if ($namespace eq 'roles' && (!$skipcheck)) {
1.1 droeschl 119: if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
120: my $cdom = $1;
121: my $cnum = $2;
1.2 droeschl 122: my ($role,$roleend,$rolestart) = split(/\_/,$value);
123: if (!$roleend || $roleend > $now) {
1.1 droeschl 124: #
125: # For active course roles, check that requesting server is running a LON-CAPA
126: # version which meets any version requirements for the course. Do not include
127: # the role amongst the results returned if the requesting server's version is
128: # too old.
129: #
130: # This determination is handled differently depending on whether the course's
131: # homeserver is the current server, or whether it is a different server.
132: # In both cases, the course's version requirement needs to be retrieved.
133: #
1.2 droeschl 134: next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
135: $minor,\%homecourses,\@ids));
1.1 droeschl 136: }
137: }
138: }
1.8.2.3.2.5! raeburn 139: if ($namespace eq 'file_permissions') {
! 140: if ($check_portaccess) {
! 141: unless ($access) {
! 142: my $unesckey = &unescape($key);
! 143: if ($unesckey =~ m{\0((\d+)_\d+_\d+:([a-z]+)_(\d+)_(\d+))$}) {
! 144: my ($acl,$timestamp,$scope,$end,$start) = ($1,$2,$3,$4);
! 145: if ($scope eq 'ip') {
! 146: unless (($start > $now) &&
! 147: ($end && $end<$now)) {
! 148: my ($path) = split(/\0/,$unesckey);
! 149: push(@{$by_ip{$path}},{$acl => $timestamp});
! 150: }
! 151: }
! 152: next;
! 153: } elsif ($unesckey =~ m{\0accesscontrol$}) {
! 154: next;
! 155: }
! 156: }
! 157: }
! 158: }
1.2 droeschl 159: if ($regexp eq '.') {
160: $count++;
161: if (defined($range) && $count >= $end) { last; }
162: if (defined($range) && $count < $start) { next; }
163: $qresult.=$key.'='.$value.'&';
164: } else {
165: my $unescapeKey = &unescape($key);
166: if (eval('$unescapeKey=~/$regexp/')) {
167: $count++;
168: if (defined($range) && $count >= $end) { last; }
169: if (defined($range) && $count < $start) { next; }
170: $qresult.="$key=$value&";
171: }
172: }
173: }
1.8.2.3.2.5! raeburn 174: if (($namespace eq 'file_permissions') && ($check_portaccess) && (!$access)) {
! 175: if (keys(%by_ip)) {
! 176: my %accesscontrol;
! 177: foreach my $path (keys(%by_ip)) {
! 178: if (ref($by_ip{$path}) eq 'ARRAY') {
! 179: foreach my $item (@{$by_ip{$path}}) {
! 180: if (ref($item) eq 'HASH') {
! 181: my ($acl,$timestamp) = each(%$item);
! 182: my $key = &escape("$path\0$acl");
! 183: my $value = $hashref->{$key};
! 184: $qresult.= "$key=$value&";
! 185: $accesscontrol{"$path\0accesscontrol"}{$acl} = $timestamp;
! 186: }
! 187: }
! 188: }
! 189: }
! 190: if (keys(%accesscontrol)) {
! 191: while (my ($key,$value) = each(%accesscontrol)) {
! 192: $qresult.= &escape($key).'='.&Apache::lonnet::freeze_escape($value).'&';
! 193: }
! 194: }
! 195: }
! 196: }
1.2 droeschl 197: &untie_user_hash($hashref) or
198: return "error: ".($!+0)." untie(GDBM) Failed while attempting dump";
1.1 droeschl 199: #
200: # If dump is for roles.db from a pre-2.10 server, check if the LON-CAPA
201: # version requirements for courses for which the current server is the home
202: # server permit course roles to be usable on the client server hosting the
203: # user's session. If so, include those role results in the data returned to
204: # the client server.
205: #
1.2 droeschl 206: if (($namespace eq 'roles') && (!$skipcheck)) {
207: if (keys(%homecourses) > 0) {
208: $qresult .= &check_homecourses(\%homecourses,$regexp,$count,
209: $range,$start,$end,$major,$minor);
210: }
211: }
212: chop($qresult);
213: return $qresult;
214: }
215:
216:
217: sub releasereqd_check {
218: my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
219: my $home = &Apache::lonnet::homeserver($cnum,$cdom);
220: return if ($home eq 'no_host');
221: my ($reqdmajor,$reqdminor,$displayrole);
222: if ($cnum =~ /$LONCAPA::match_community/) {
223: if ($major eq '' && $minor eq '') {
224: return unless ((ref($ids) eq 'ARRAY') &&
225: (grep(/^\Q$home\E$/,@{$ids})));
226: } else {
227: $reqdmajor = 2;
228: $reqdminor = 9;
229: return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
230: }
231: }
232: my $hashid = $cdom.':'.$cnum;
233: my ($courseinfo,$cached) =
234: &Apache::lonnet::is_cached_new('courseinfo',$hashid);
235: if (defined($cached)) {
236: if (ref($courseinfo) eq 'HASH') {
237: if (exists($courseinfo->{'releaserequired'})) {
238: my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
239: return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
240: }
241: }
242: } else {
243: if (ref($ids) eq 'ARRAY') {
244: if (grep(/^\Q$home\E$/,@{$ids})) {
245: if (ref($homecourses) eq 'HASH') {
246: if (ref($homecourses->{$cdom}) eq 'HASH') {
247: if (ref($homecourses->{$cdom}{$cnum}) eq 'HASH') {
248: if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
249: push(@{$homecourses->{$cdom}{$cnum}},{$key=>$value});
250: } else {
251: $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
252: }
253: } else {
254: $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
255: }
256: } else {
257: $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
258: }
259: }
260: return;
261: }
262: }
263: my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
264: if (ref($courseinfo) eq 'HASH') {
265: if (exists($courseinfo->{'releaserequired'})) {
266: my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
267: return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
268: }
269: } else {
270: return;
271: }
272: }
273: return 1;
274: }
275:
276:
277: sub check_homecourses {
278: my ($homecourses,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
279: my ($result,%addtocache);
280: my $yesterday = time - 24*3600;
281: if (ref($homecourses) eq 'HASH') {
282: my (%okcourses,%courseinfo,%recent);
283: foreach my $domain (keys(%{$homecourses})) {
284: my $hashref =
285: &tie_domain_hash($domain, "nohist_courseids", &GDBM_WRCREAT());
286: if (ref($hashref) eq 'HASH') {
287: while (my ($key,$value) = each(%$hashref)) {
288: my $unesc_key = &unescape($key);
289: if ($unesc_key =~ /^lasttime:(\w+)$/) {
290: my $cid = $1;
291: $cid =~ s/_/:/;
292: if ($value > $yesterday ) {
293: $recent{$cid} = 1;
294: }
295: next;
296: }
297: my $items = &Apache::lonnet::thaw_unescape($value);
298: if (ref($items) eq 'HASH') {
299: my ($cdom,$cnum) = split(/_/,$unesc_key);
300: my $hashid = $cdom.':'.$cnum;
301: $courseinfo{$hashid} = $items;
302: if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
303: my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
304: if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
305: $okcourses{$hashid} = 1;
306: }
307: }
308: }
309: }
310: unless (&untie_domain_hash($hashref)) {
1.8.2.3 raeburn 311: &Apache::lonnet::logthis("Failed to untie tied hash for nohist_courseids.db for $domain");
1.2 droeschl 312: }
313: } else {
1.8.2.3 raeburn 314: &Apache::lonnet::logthis("Failed to tie hash for nohist_courseids.db for $domain");
1.2 droeschl 315: }
316: }
317: foreach my $hashid (keys(%recent)) {
318: my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
319: unless ($cached) {
320: &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
321: }
322: }
323: foreach my $cdom (keys(%{$homecourses})) {
324: if (ref($homecourses->{$cdom}) eq 'HASH') {
325: foreach my $cnum (keys(%{$homecourses->{$cdom}})) {
326: my $hashid = $cdom.':'.$cnum;
327: next if ($recent{$hashid});
328: &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
329: }
330: }
331: }
332: foreach my $hashid (keys(%okcourses)) {
333: my ($cdom,$cnum) = split(/:/,$hashid);
334: if ((ref($homecourses->{$cdom}) eq 'HASH') &&
335: (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY')) {
336: foreach my $role (@{$homecourses->{$cdom}{$cnum}}) {
337: if (ref($role) eq 'HASH') {
338: while (my ($key,$value) = each(%{$role})) {
339: if ($regexp eq '.') {
340: $count++;
341: if (defined($range) && $count >= $end) { last; }
342: if (defined($range) && $count < $start) { next; }
343: $result.=$key.'='.$value.'&';
344: } else {
345: my $unescapeKey = &unescape($key);
346: if (eval('$unescapeKey=~/$regexp/')) {
347: $count++;
348: if (defined($range) && $count >= $end) { last; }
349: if (defined($range) && $count < $start) { next; }
350: $result.="$key=$value&";
351: }
352: }
353: }
354: }
1.1 droeschl 355: }
356: }
1.2 droeschl 357: }
1.1 droeschl 358: }
1.2 droeschl 359: return $result;
360: }
361:
1.1 droeschl 362:
1.2 droeschl 363: sub useable_role {
364: my ($reqdmajor,$reqdminor,$major,$minor) = @_;
365: if ($reqdmajor ne '' && $reqdminor ne '') {
366: return if (($major eq '' && $minor eq '') ||
367: ($major < $reqdmajor) ||
368: (($major == $reqdmajor) && ($minor < $reqdminor)));
369: }
1.1 droeschl 370: return 1;
371: }
372:
1.2 droeschl 373:
1.3 droeschl 374: sub get_courseinfo_hash {
375: my ($cnum,$cdom,$home) = @_;
376: my %info;
377: eval {
378: local($SIG{ALRM}) = sub { die "timeout\n"; };
379: local($SIG{__DIE__})='DEFAULT';
380: alarm(3);
381: %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
382: alarm(0);
383: };
384: if ($@) {
385: if ($@ eq "timeout\n") {
1.8.2.3 raeburn 386: &Apache::lonnet::logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
1.3 droeschl 387: } else {
1.8.2.3 raeburn 388: &Apache::lonnet::logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
1.3 droeschl 389: }
390: } else {
391: if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
392: my $hashid = $cdom.':'.$cnum;
393: return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
394: }
395: }
396: return;
397: }
1.2 droeschl 398:
1.8.2.3.2.5! raeburn 399: sub portfolio_is_shareable {
! 400: my ($udom,$uname) = @_;
! 401: my $check_portaccess = 1;
! 402: my ($userportaccess,$inststatus,$access);
! 403: my $hashref = &tie_user_hash($udom, $uname, 'environment', &GDBM_READER());
! 404: if (ref($hashref) eq 'HASH') {
! 405: my $accesskey = &escape('tools.portaccess');
! 406: $userportaccess = $hashref->{$accesskey};
! 407: $inststatus = $hashref->{'inststatus'};
! 408: &untie_user_hash($hashref);
! 409: }
! 410: if ($userportaccess ne '') {
! 411: $access = $userportaccess;
! 412: } else {
! 413: my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
! 414: if (ref($domdefs{'portaccess'}) eq 'HASH') {
! 415: if (($domdefs{'portaccess'}{'_LC_adv'} ne '') &&
! 416: (&Apache::lonnet::is_advanced_user($udom,$uname))) {
! 417: if ($domdefs{'portaccess'}{'_LC_adv'}) {
! 418: $access = 1;
! 419: } else {
! 420: $access = 0;
! 421: }
! 422: } elsif ($inststatus ne '') {
! 423: my ($hasaccess,$hasnoaccess);
! 424: foreach my $affiliation (split(/:/,$inststatus)) {
! 425: if ($domdefs{'portaccess'}{$affiliation} ne '') {
! 426: if ($domdefs{'portaccess'}{$affiliation}) {
! 427: $hasaccess = 1;
! 428: } else {
! 429: $hasnoaccess = 1;
! 430: }
! 431: }
! 432: }
! 433: if ($hasaccess || $hasnoaccess) {
! 434: if ($hasaccess) {
! 435: $access = 1;
! 436: } elsif ($hasnoaccess) {
! 437: $access = 0;
! 438: }
! 439: }
! 440: } else {
! 441: if ($domdefs{'portaccess'}{'default'} ne '') {
! 442: if ($domdefs{'portaccess'}{'default'}) {
! 443: $access = 1;
! 444: } elsif ($domdefs{'portaccess'}{'default'} == 0) {
! 445: $access = 0;
! 446: }
! 447: }
! 448: }
! 449: } else {
! 450: $access = 1;
! 451: }
! 452: }
! 453: return $access;
! 454: }
! 455:
1.4 droeschl 456: sub dump_course_id_handler {
457: my ($tail) = @_;
458:
459: my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
460: $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
461: $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
1.7 raeburn 462: $creationcontext,$domcloner,$hasuniquecode,$reqcrsdom,$reqinstcode) = split(/:/,$tail);
1.4 droeschl 463: my $now = time;
464: my ($cloneruname,$clonerudom,%cc_clone);
465: if (defined($description)) {
466: $description=&unescape($description);
467: } else {
468: $description='.';
469: }
470: if (defined($instcodefilter)) {
471: $instcodefilter=&unescape($instcodefilter);
472: } else {
473: $instcodefilter='.';
474: }
475: my ($ownerunamefilter,$ownerdomfilter);
476: if (defined($ownerfilter)) {
477: $ownerfilter=&unescape($ownerfilter);
478: if ($ownerfilter ne '.' && defined($ownerfilter)) {
479: if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
480: $ownerunamefilter = $1;
481: $ownerdomfilter = $2;
482: } else {
483: $ownerunamefilter = $ownerfilter;
484: $ownerdomfilter = '';
485: }
486: }
487: } else {
488: $ownerfilter='.';
489: }
490:
491: if (defined($coursefilter)) {
492: $coursefilter=&unescape($coursefilter);
493: } else {
494: $coursefilter='.';
495: }
496: if (defined($typefilter)) {
497: $typefilter=&unescape($typefilter);
498: } else {
499: $typefilter='.';
500: }
501: if (defined($regexp_ok)) {
502: $regexp_ok=&unescape($regexp_ok);
503: }
504: if (defined($catfilter)) {
505: $catfilter=&unescape($catfilter);
506: }
507: if (defined($cloner)) {
508: $cloner = &unescape($cloner);
509: ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/);
510: }
511: if (defined($cc_clone_list)) {
512: $cc_clone_list = &unescape($cc_clone_list);
513: my @cc_cloners = split('&',$cc_clone_list);
514: foreach my $cid (@cc_cloners) {
515: my ($clonedom,$clonenum) = split(':',$cid);
516: next if ($clonedom ne $udom);
517: $cc_clone{$clonedom.'_'.$clonenum} = 1;
518: }
519: }
520: if ($createdbefore ne '') {
521: $createdbefore = &unescape($createdbefore);
522: } else {
523: $createdbefore = 0;
524: }
525: if ($createdafter ne '') {
526: $createdafter = &unescape($createdafter);
527: } else {
528: $createdafter = 0;
529: }
530: if ($creationcontext ne '') {
531: $creationcontext = &unescape($creationcontext);
532: } else {
533: $creationcontext = '.';
534: }
1.6 raeburn 535: unless ($hasuniquecode) {
536: $hasuniquecode = '.';
537: }
1.8 raeburn 538: if ($reqinstcode ne '') {
539: $reqinstcode = &unescape($reqinstcode);
540: }
1.4 droeschl 541: my $unpack = 1;
542: if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' &&
543: $typefilter eq '.') {
544: $unpack = 0;
545: }
546: if (!defined($since)) { $since=0; }
1.7 raeburn 547: my (%gotcodedefaults,%otcodedefaults);
1.4 droeschl 548: my $qresult='';
549:
550: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT())
551: or return "error: ".($!+0)." tie(GDBM) Failed while attempting courseiddump";
552:
553: while (my ($key,$value) = each(%$hashref)) {
554: my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
555: %unesc_val,$selfenroll_end,$selfenroll_types,$created,
556: $context);
557: $unesc_key = &unescape($key);
558: if ($unesc_key =~ /^lasttime:/) {
559: next;
560: } else {
561: $lasttime_key = &escape('lasttime:'.$unesc_key);
562: }
563: if ($hashref->{$lasttime_key} ne '') {
564: $lasttime = $hashref->{$lasttime_key};
565: next if ($lasttime<$since);
566: }
1.7 raeburn 567: my ($canclone,$valchange,$clonefromcode);
1.4 droeschl 568: my $items = &Apache::lonnet::thaw_unescape($value);
569: if (ref($items) eq 'HASH') {
570: if ($hashref->{$lasttime_key} eq '') {
571: next if ($since > 1);
572: }
1.7 raeburn 573: if ($items->{'inst_code'}) {
574: $clonefromcode = $items->{'inst_code'};
575: }
1.4 droeschl 576: $is_hash = 1;
577: if ($domcloner) {
578: $canclone = 1;
579: } elsif (defined($clonerudom)) {
580: if ($items->{'cloners'}) {
581: my @cloneable = split(',',$items->{'cloners'});
582: if (@cloneable) {
583: if (grep(/^\*$/,@cloneable)) {
584: $canclone = 1;
585: } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
586: $canclone = 1;
587: } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
588: $canclone = 1;
589: }
590: }
591: unless ($canclone) {
592: if ($cloneruname ne '' && $clonerudom ne '') {
593: if ($cc_clone{$unesc_key}) {
594: $canclone = 1;
595: $items->{'cloners'} .= ','.$cloneruname.':'.
596: $clonerudom;
597: $valchange = 1;
598: }
599: }
600: }
1.7 raeburn 601: unless ($canclone) {
602: if (($reqcrsdom eq $udom) && ($reqinstcode) && ($clonefromcode)) {
603: if (grep(/\=/,@cloneable)) {
604: foreach my $cloner (@cloneable) {
605: if (($cloner ne '*') && ($cloner !~ /^\*\:$LONCAPA::match_domain$/) &&
606: ($cloner !~ /^$LONCAPA::match_username\:$LONCAPA::match_domain$/) && ($cloner ne '')) {
607: if ($cloner =~ /=/) {
608: my (%codedefaults,@code_order);
609: if (ref($gotcodedefaults{$udom}) eq 'HASH') {
610: if (ref($gotcodedefaults{$udom}{'defaults'}) eq 'HASH') {
611: %codedefaults = %{$gotcodedefaults{$udom}{'defaults'}};
612: }
613: if (ref($gotcodedefaults{$udom}{'order'}) eq 'ARRAY') {
614: @code_order = @{$gotcodedefaults{$udom}{'order'}};
615: }
616: } else {
617: &Apache::lonnet::auto_instcode_defaults($udom,
618: \%codedefaults,
619: \@code_order);
620: $gotcodedefaults{$udom}{'defaults'} = \%codedefaults;
621: $gotcodedefaults{$udom}{'order'} = \@code_order;
622: }
623: if (@code_order > 0) {
624: if (&Apache::lonnet::check_instcode_cloning(\%codedefaults,\@code_order,
625: $cloner,$clonefromcode,$reqinstcode)) {
626: $canclone = 1;
627: last;
628: }
629: }
630: }
631: }
632: }
633: }
634: }
635: }
1.4 droeschl 636: } elsif (defined($cloneruname)) {
637: if ($cc_clone{$unesc_key}) {
638: $canclone = 1;
639: $items->{'cloners'} = $cloneruname.':'.$clonerudom;
640: $valchange = 1;
641: }
642: unless ($canclone) {
643: if ($items->{'owner'} =~ /:/) {
644: if ($items->{'owner'} eq $cloner) {
645: $canclone = 1;
646: }
647: } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
648: $canclone = 1;
649: }
650: if ($canclone) {
651: $items->{'cloners'} = $cloneruname.':'.$clonerudom;
652: $valchange = 1;
653: }
654: }
655: }
1.7 raeburn 656: unless (($canclone) || ($items->{'cloners'})) {
657: my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
658: if ($domdefs{'canclone'}) {
659: unless ($domdefs{'canclone'} eq 'none') {
660: if ($domdefs{'canclone'} eq 'domain') {
661: if ($clonerudom eq $udom) {
662: $canclone = 1;
663: }
664: } elsif (($clonefromcode) && ($reqinstcode) &&
665: ($udom eq $reqcrsdom)) {
666: if (&Apache::lonnet::default_instcode_cloning($udom,$domdefs{'canclone'},
667: $clonefromcode,$reqinstcode)) {
668: $canclone = 1;
669: }
670: }
671: }
672: }
673: }
1.4 droeschl 674: }
675: if ($unpack || !$rtn_as_hash) {
676: $unesc_val{'descr'} = $items->{'description'};
677: $unesc_val{'inst_code'} = $items->{'inst_code'};
678: $unesc_val{'owner'} = $items->{'owner'};
679: $unesc_val{'type'} = $items->{'type'};
680: $unesc_val{'cloners'} = $items->{'cloners'};
681: $unesc_val{'created'} = $items->{'created'};
682: $unesc_val{'context'} = $items->{'context'};
683: }
684: $selfenroll_types = $items->{'selfenroll_types'};
685: $selfenroll_end = $items->{'selfenroll_end_date'};
686: $created = $items->{'created'};
687: $context = $items->{'context'};
688: if ($selfenrollonly) {
689: next if (!$selfenroll_types);
690: if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
691: next;
692: }
693: }
694: if ($creationcontext ne '.') {
695: next if (($context ne '') && ($context ne $creationcontext));
696: }
697: if ($createdbefore > 0) {
698: next if (($created eq '') || ($created > $createdbefore));
699: }
700: if ($createdafter > 0) {
701: next if (($created eq '') || ($created <= $createdafter));
702: }
703: if ($catfilter ne '') {
704: next if ($items->{'categories'} eq '');
705: my @categories = split('&',$items->{'categories'});
706: next if (@categories == 0);
707: my @subcats = split('&',$catfilter);
708: my $matchcat = 0;
709: foreach my $cat (@categories) {
710: if (grep(/^\Q$cat\E$/,@subcats)) {
711: $matchcat = 1;
712: last;
713: }
714: }
715: next if (!$matchcat);
716: }
717: if ($caller eq 'coursecatalog') {
718: if ($items->{'hidefromcat'} eq 'yes') {
719: next if !$showhidden;
720: }
721: }
1.6 raeburn 722: if ($hasuniquecode ne '.') {
723: next unless ($items->{'uniquecode'});
724: }
1.4 droeschl 725: } else {
726: next if ($catfilter ne '');
727: next if ($selfenrollonly);
728: next if ($createdbefore || $createdafter);
729: next if ($creationcontext ne '.');
730: if ((defined($clonerudom)) && (defined($cloneruname))) {
731: if ($cc_clone{$unesc_key}) {
732: $canclone = 1;
733: $val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
734: }
735: }
736: $is_hash = 0;
737: my @courseitems = split(/:/,$value);
738: $lasttime = pop(@courseitems);
739: if ($hashref->{$lasttime_key} eq '') {
740: next if ($lasttime<$since);
741: }
742: ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
743: }
744: if ($cloneonly) {
745: next unless ($canclone);
746: }
747: my $match = 1;
748: if ($description ne '.') {
749: if (!$is_hash) {
750: $unesc_val{'descr'} = &unescape($val{'descr'});
751: }
752: if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
753: $match = 0;
754: }
755: }
756: if ($instcodefilter ne '.') {
757: if (!$is_hash) {
758: $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
759: }
760: if ($regexp_ok == 1) {
761: if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
762: $match = 0;
763: }
764: } elsif ($regexp_ok == -1) {
765: if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
766: $match = 0;
767: }
768: } else {
769: if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
770: $match = 0;
771: }
772: }
773: }
774: if ($ownerfilter ne '.') {
775: if (!$is_hash) {
776: $unesc_val{'owner'} = &unescape($val{'owner'});
777: }
778: if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
779: if ($unesc_val{'owner'} =~ /:/) {
780: if (eval{$unesc_val{'owner'} !~
781: /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
782: $match = 0;
783: }
784: } else {
785: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
786: $match = 0;
787: }
788: }
789: } elsif ($ownerunamefilter ne '') {
790: if ($unesc_val{'owner'} =~ /:/) {
791: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
792: $match = 0;
793: }
794: } else {
795: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
796: $match = 0;
797: }
798: }
799: } elsif ($ownerdomfilter ne '') {
800: if ($unesc_val{'owner'} =~ /:/) {
801: if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
802: $match = 0;
803: }
804: } else {
805: if ($ownerdomfilter ne $udom) {
806: $match = 0;
807: }
808: }
809: }
810: }
811: if ($coursefilter ne '.') {
812: if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
813: $match = 0;
814: }
815: }
816: if ($typefilter ne '.') {
817: if (!$is_hash) {
818: $unesc_val{'type'} = &unescape($val{'type'});
819: }
820: if ($unesc_val{'type'} eq '') {
821: if ($typefilter ne 'Course') {
822: $match = 0;
823: }
824: } else {
825: if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
826: $match = 0;
827: }
828: }
829: }
830: if ($match == 1) {
831: if ($rtn_as_hash) {
832: if ($is_hash) {
833: if ($valchange) {
834: my $newvalue = &Apache::lonnet::freeze_escape($items);
835: $qresult.=$key.'='.$newvalue.'&';
836: } else {
837: $qresult.=$key.'='.$value.'&';
838: }
839: } else {
840: my %rtnhash = ( 'description' => &unescape($val{'descr'}),
841: 'inst_code' => &unescape($val{'inst_code'}),
842: 'owner' => &unescape($val{'owner'}),
843: 'type' => &unescape($val{'type'}),
844: 'cloners' => &unescape($val{'cloners'}),
845: );
846: my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
847: $qresult.=$key.'='.$items.'&';
848: }
849: } else {
850: if ($is_hash) {
851: $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
852: &escape($unesc_val{'inst_code'}).':'.
853: &escape($unesc_val{'owner'}).'&';
854: } else {
855: $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
856: ':'.$val{'owner'}.'&';
857: }
858: }
859: }
860: }
861: &untie_domain_hash($hashref) or
862: return "error: ".($!+0)." untie(GDBM) Failed while attempting courseiddump";
863:
864: chop($qresult);
865: return $qresult;
866: }
867:
868: sub dump_profile_database {
869: my ($tail) = @_;
870:
871: my ($udom,$uname,$namespace) = split(/:/,$tail);
872:
873: my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()) or
874: return "error: ".($!+0)." tie(GDBM) Failed while attempting currentdump";
875:
876: # Structure of %data:
877: # $data{$symb}->{$parameter}=$value;
878: # $data{$symb}->{'v.'.$parameter}=$version;
879: # since $parameter will be unescaped, we do not
880: # have to worry about silly parameter names...
881:
882: my $qresult='';
883: my %data = (); # A hash of anonymous hashes..
884: while (my ($key,$value) = each(%$hashref)) {
885: my ($v,$symb,$param) = split(/:/,$key);
886: next if ($v eq 'version' || $symb eq 'keys');
887: next if (exists($data{$symb}) &&
888: exists($data{$symb}->{$param}) &&
889: $data{$symb}->{'v.'.$param} > $v);
890: $data{$symb}->{$param}=$value;
891: $data{$symb}->{'v.'.$param}=$v;
892: }
893:
894: &untie_user_hash($hashref) or
895: return "error: ".($!+0)." untie(GDBM) Failed while attempting currentdump";
896:
897: while (my ($symb,$param_hash) = each(%data)) {
898: while(my ($param,$value) = each (%$param_hash)){
899: next if ($param =~ /^v\./); # Ignore versions...
900: #
901: # Just dump the symb=value pairs separated by &
902: #
903: $qresult.=$symb.':'.$param.'='.$value.'&';
904: }
905: }
1.2 droeschl 906:
1.4 droeschl 907: chop($qresult);
908: return $qresult;
909: }
1.2 droeschl 910:
1.8.2.1 raeburn 911: sub is_course {
912: my ($cdom,$cnum) = @_;
913:
914: return unless (($cdom =~ /^$LONCAPA::match_domain$/) &&
915: ($cnum =~ /^$LONCAPA::match_courseid$/));
916: my $hashid = $cdom.':'.$cnum;
917: my ($iscourse,$cached) =
918: &Apache::lonnet::is_cached_new('iscourse',$hashid);
919: unless (defined($cached)) {
920: my $hashref =
921: &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
922: if (ref($hashref) eq 'HASH') {
923: my $esc_key = &escape($cdom.'_'.$cnum);
924: if (exists($hashref->{$esc_key})) {
925: $iscourse = 1;
926: } else {
927: $iscourse = 0;
928: }
929: &Apache::lonnet::do_cache_new('iscourse',$hashid,$iscourse,3600);
930: unless (&untie_domain_hash($hashref)) {
1.8.2.3 raeburn 931: &Apache::lonnet::logthis("Failed to untie tied hash for nohist_courseids.db for $cdom");
1.8.2.1 raeburn 932: }
933: } else {
1.8.2.3 raeburn 934: &Apache::lonnet::logthis("Failed to tie hash for nohist_courseids.db for $cdom");
1.8.2.1 raeburn 935: }
936: }
937: return $iscourse;
938: }
1.2 droeschl 939:
1.8.2.2 raeburn 940: sub get_dom {
941: my ($userinput) = @_;
942: my ($cmd,$udom,$namespace,$what) =split(/:/,$userinput,4);
943: my $hashref = &tie_domain_hash($udom,$namespace,&GDBM_READER()) or
944: return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd";
945: my $qresult='';
946: if (ref($hashref)) {
947: chomp($what);
948: my @queries=split(/\&/,$what);
949: for (my $i=0;$i<=$#queries;$i++) {
950: $qresult.="$hashref->{$queries[$i]}&";
951: }
952: $qresult=~s/\&$//;
953: }
954: &untie_user_hash($hashref) or
955: return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd";
956: return $qresult;
957: }
958:
1.8.2.3.2.3 raeburn 959: sub store_dom {
960: my ($userinput) = @_;
961: my ($cmd,$dom,$namespace,$rid,$what) =split(/:/,$userinput);
962: my $hashref = &tie_domain_hash($dom,$namespace,&GDBM_WRCREAT(),"S","$rid:$what") or
963: return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd";
964: $hashref->{"version:$rid"}++;
965: my $version=$hashref->{"version:$rid"};
966: my $allkeys='';
967: my @pairs=split(/\&/,$what);
968: foreach my $pair (@pairs) {
969: my ($key,$value)=split(/=/,$pair);
970: $allkeys.=$key.':';
971: $hashref->{"$version:$rid:$key"}=$value;
972: }
973: my $now = time;
974: $hashref->{"$version:$rid:timestamp"}=$now;
975: $allkeys.='timestamp';
976: $hashref->{"$version:keys:$rid"}=$allkeys;
977: &untie_user_hash($hashref) or
978: return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd";
979: return 'ok';
980: }
981:
982: sub restore_dom {
983: my ($userinput) = @_;
984: my ($cmd,$dom,$namespace,$rid) = split(/:/,$userinput);
985: my $hashref = &tie_domain_hash($dom,$namespace,&GDBM_READER()) or
986: return "error: ".($!+0)." tie(GDBM) Failed while attempting $cmd";
987: my $qresult='';
988: if (ref($hashref)) {
989: chomp($rid);
990: my $version=$hashref->{"version:$rid"};
991: $qresult.="version=$version&";
992: my $scope;
993: for ($scope=1;$scope<=$version;$scope++) {
994: my $vkeys=$hashref->{"$scope:keys:$rid"};
995: my @keys=split(/:/,$vkeys);
996: my $key;
997: $qresult.="$scope:keys=$vkeys&";
998: foreach $key (@keys) {
999: $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
1000: }
1001: }
1002: $qresult=~s/\&$//;
1003: }
1004: &untie_user_hash($hashref) or
1005: return "error: ".($!+0)." untie(GDBM) Failed while attempting $cmd";
1006: return $qresult;
1007: }
1008:
1.8.2.3.2.1 raeburn 1009: sub crslti_itemid {
1010: my ($cdom,$cnum,$url,$method,$params,$loncaparev) = @_;
1011: unless (ref($params) eq 'HASH') {
1012: return;
1013: }
1014: if (($cdom eq '') || ($cnum eq '')) {
1015: return;
1016: }
1017: my ($itemid,$consumer_key,$secret);
1018:
1019: if (exists($params->{'oauth_callback'})) {
1020: $Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0A;
1021: } else {
1022: $Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0;
1023: }
1024:
1025: my $consumer_key = $params->{'oauth_consumer_key'};
1026: return if ($consumer_key eq '');
1027:
1028: my (%crslti,%crslti_by_key);
1029: my $hashid=$cdom.'_'.$cnum;
1030: my ($result,$cached)=&Apache::lonnet::is_cached_new('courseltienc',$hashid);
1031: if (defined($cached)) {
1032: if (ref($result) eq 'HASH') {
1033: %crslti = %{$result};
1034: }
1035: } else {
1036: my $reply = &dump_with_regexp(join(":",($cdom,$cnum,'nohist_ltienc','','')),$loncaparev);
1037: %crslti = %{&Apache::lonnet::unserialize($reply)};
1038: my $cachetime = 24*60*60;
1039: &Apache::lonnet::do_cache_new('courseltienc',$hashid,\%crslti,$cachetime);
1040: }
1041:
1042: return if (!keys(%crslti));
1043:
1044: foreach my $id (keys(%crslti)) {
1045: if (ref($crslti{$id}) eq 'HASH') {
1046: my $key = $crslti{$id}{'key'};
1047: if (($key ne '') && ($crslti{$id}{'secret'} ne '')) {
1048: push(@{$crslti_by_key{$key}},$id);
1049: }
1050: }
1051: }
1052:
1053: return if (!keys(%crslti_by_key));
1054:
1.8.2.3.2.3 raeburn 1055: my %courselti = &Apache::lonnet::get_course_lti($cnum,$cdom,'provider');
1056:
1.8.2.3.2.1 raeburn 1057: if (ref($crslti_by_key{$consumer_key}) eq 'ARRAY') {
1058: foreach my $id (@{$crslti_by_key{$consumer_key}}) {
1059: my $secret = $crslti{$id}{'secret'};
1.8.2.3.2.3 raeburn 1060: if (ref($courselti{$id}) eq 'HASH') {
1061: if ((exists($courselti{$id}{'cipher'})) &&
1062: ($courselti{$id}{'cipher'} =~ /^\d+$/)) {
1063: my $keynum = $courselti{$id}{'cipher'};
1064: my $privkey = &get_dom("getdom:$cdom:private:$keynum:lti:key");
1065: if ($privkey ne '') {
1066: my $cipher = new Crypt::CBC($privkey);
1067: $secret = $cipher->decrypt_hex($secret);
1068: }
1069: }
1070: }
1.8.2.3.2.1 raeburn 1071: my $request = Net::OAuth->request('request token')->from_hash($params,
1072: request_url => $url,
1073: request_method => $method,
1074: consumer_secret => $secret,);
1075: if ($request->verify()) {
1076: $itemid = $id;
1077: last;
1078: }
1079: }
1080: }
1081: return $itemid;
1082: }
1083:
1084: sub domlti_itemid {
1085: my ($dom,$context,$url,$method,$params,$loncaparev) = @_;
1086: unless (ref($params) eq 'HASH') {
1087: return;
1088: }
1089: if ($dom eq '') {
1090: return;
1091: }
1092: my ($itemid,$consumer_key,$secret);
1093:
1094: if (exists($params->{'oauth_callback'})) {
1095: $Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0A;
1096: } else {
1097: $Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0;
1098: }
1099:
1100: my $consumer_key = $params->{'oauth_consumer_key'};
1101: return if ($consumer_key eq '');
1102:
1.8.2.3.2.3 raeburn 1103: my ($name,$cachename);
1104: if ($context eq 'linkprot') {
1105: $name = $context;
1106: } else {
1107: $name = 'lti';
1.8.2.3.2.4 raeburn 1108: if ($context eq '') {
1109: $context = 'provider';
1110: }
1.8.2.3.2.3 raeburn 1111: }
1112: $cachename = $name.'enc';
1.8.2.3.2.1 raeburn 1113: my %ltienc;
1.8.2.3.2.3 raeburn 1114: my ($encresult,$enccached)=&Apache::lonnet::is_cached_new($cachename,$dom);
1.8.2.3.2.1 raeburn 1115: if (defined($enccached)) {
1116: if (ref($encresult) eq 'HASH') {
1117: %ltienc = %{$encresult};
1118: }
1119: } else {
1.8.2.3.2.3 raeburn 1120: my $reply = &get_dom("getdom:$dom:encconfig:$name");
1.8.2.3.2.1 raeburn 1121: my $ltiencref = &Apache::lonnet::thaw_unescape($reply);
1122: if (ref($ltiencref) eq 'HASH') {
1123: %ltienc = %{$ltiencref};
1124: }
1125: my $cachetime = 24*60*60;
1.8.2.3.2.3 raeburn 1126: &Apache::lonnet::do_cache_new($cachename,$dom,\%ltienc,$cachetime);
1.8.2.3.2.1 raeburn 1127: }
1128:
1129: return if (!keys(%ltienc));
1130:
1131: my %lti_by_key;
1132: foreach my $id (keys(%ltienc)) {
1133: if (ref($ltienc{$id}) eq 'HASH') {
1134: my $key = $ltienc{$id}{'key'};
1135: if (($key ne '') && ($ltienc{$id}{'secret'} ne '')) {
1.8.2.3.2.3 raeburn 1136: push(@{$lti_by_key{$key}},$id);
1.8.2.3.2.1 raeburn 1137: }
1138: }
1139: }
1140: return if (!keys(%lti_by_key));
1141:
1.8.2.3.2.3 raeburn 1142: my %lti = &Apache::lonnet::get_domain_lti($dom,$context);
1143:
1.8.2.3.2.1 raeburn 1144: if (ref($lti_by_key{$consumer_key}) eq 'ARRAY') {
1145: foreach my $id (@{$lti_by_key{$consumer_key}}) {
1146: my $secret = $ltienc{$id}{'secret'};
1.8.2.3.2.3 raeburn 1147: if (ref($lti{$id}) eq 'HASH') {
1148: if ((exists($lti{$id}{'cipher'})) &&
1149: ($lti{$id}{'cipher'} =~ /^\d+$/)) {
1150: my $keynum = $lti{$id}{'cipher'};
1151: my $privkey = &get_dom("getdom:$dom:private:$keynum:lti:key");
1152: if ($privkey ne '') {
1153: my $cipher = new Crypt::CBC($privkey);
1154: $secret = $cipher->decrypt_hex($secret);
1155: }
1156: }
1157: }
1.8.2.3.2.1 raeburn 1158: my $request = Net::OAuth->request('request token')->from_hash($params,
1159: request_url => $url,
1160: request_method => $method,
1161: consumer_secret => $secret,);
1162: if ($request->verify()) {
1163: $itemid = $id;
1164: last;
1165: }
1166: }
1167: }
1168: return $itemid;
1169: }
1170:
1.8.2.3.2.4 raeburn 1171: sub sign_lti_payload {
1172: my ($cdom,$cnum,$crsdef,$type,$context,$url,$idx,$keynum,$loncaparev,$paramsref,$inforef) = @_;
1173: return unless (ref($paramsref) eq 'HASH');
1174: my ($sigmethod,$callback,$reqtype,$reqmethod,$respfmt,$bodyhash);
1175: if (ref($inforef) eq 'HASH') {
1176: if (exists($inforef->{'method'})) {
1177: $sigmethod = $inforef->{'method'};
1178: }
1179: if (exists($inforef->{'cb'})) {
1180: $callback = $inforef->{'cb'};
1181: }
1182: if (exists($inforef->{'reqtype'})) {
1183: $reqtype = $inforef->{'reqtype'};
1184: }
1185: if (exists($inforef->{'reqmethod'})) {
1186: $reqmethod = $inforef->{'reqmethod'};
1187: }
1188: if (exists($inforef->{'body_hash'})) {
1189: $bodyhash = $inforef->{'body_hash'};
1190: }
1191: if (exists($inforef->{'respfmt'})) {
1192: $respfmt = $inforef->{'respfmt'};
1193: }
1194: }
1195: my ($key,$secret) = &get_lti_credentials($cdom,$cnum,$crsdef,$type,$idx,$keynum,$loncaparev);
1196: return if (($key eq '') || ($secret eq ''));
1197: if ($sigmethod eq '') {
1198: $sigmethod = 'HMAC-SHA1';
1199: }
1200: if ($callback eq '') {
1201: $callback = 'about:blank',
1202: }
1203: if ($reqtype eq '') {
1204: $reqtype = 'request token';
1205: }
1206: if ($reqmethod eq '') {
1207: $reqmethod = 'POST';
1208: }
1209: srand( time() ^ ($$ + ($$ << 15)) ); # Seed rand.
1210: my $nonce = Digest::SHA::sha1_hex(sprintf("%06x%06x",rand(0xfffff0),rand(0xfffff0)));
1211: my $request;
1212: if (($context eq 'grade') && ($reqtype eq 'consumer') && ($bodyhash ne '')) {
1213: $request = Net::OAuth->request($reqtype)->new(
1214: consumer_key => $key,
1215: consumer_secret => $secret,
1216: request_url => $url,
1217: request_method => $reqmethod,
1218: signature_method => $sigmethod,
1219: timestamp => time(),
1220: nonce => $nonce,
1221: body_hash => $bodyhash,
1222: );
1223: $request->add_required_message_params('body_hash');
1224: } else {
1225: $request = Net::OAuth->request($reqtype)->new(
1226: consumer_key => $key,
1227: consumer_secret => $secret,
1228: request_url => $url,
1229: request_method => 'POST',
1230: signature_method => $sigmethod,
1231: timestamp => time,
1232: nonce => $nonce,
1233: callback => $callback,
1234: extra_params => $paramsref,
1235: version => '1.0',
1236: );
1237: }
1238: $request->sign();
1239: if ($respfmt eq 'to_post_body') {
1240: return $request->to_post_body();
1241: } elsif ($respfmt eq 'to_authorization_header') {
1242: return $request->to_authorization_header();
1243: } else {
1244: return $request->to_hash();
1245: }
1246: }
1247:
1248: sub get_lti_credentials {
1249: my ($cdom,$cnum,$crsdef,$type,$idx,$keynum,$loncaparev) = @_;
1250: my ($dbname,$name,$cachename,$hashid,$key,$secret,%ltienc);
1251: if ($crsdef) {
1252: $hashid = $cdom.'_'.$cnum;
1253: } else {
1254: $hashid = $cdom;
1255: }
1256: if ($type eq 'tools') {
1257: if ($crsdef) {
1258: $dbname = 'nohist_toolsenc';
1259: $cachename = 'crsltitoolsenc';
1260: } else {
1261: $name = 'ltitools';
1262: $dbname = 'encconfig';
1263: $cachename = 'ltitoolsenc';
1264: }
1265: } elsif ($type eq 'linkprot') {
1266: if ($crsdef) {
1267: $dbname = 'nohist_ltienc';
1268: $cachename = 'courseltienc';
1269: } else {
1270: $name = 'linkprot';
1271: $dbname = 'encconfig';
1272: $cachename = 'linkprotenc';
1273: }
1274: } elsif ($type eq 'lti') {
1275: $name = 'lti';
1276: $dbname = 'encconfig';
1277: $cachename = 'ltienc';
1278: }
1279: my ($encresult,$enccached)=&Apache::lonnet::is_cached_new($cachename,$hashid);
1280: if (defined($enccached)) {
1281: if (ref($encresult) eq 'HASH') {
1282: %ltienc = %{$encresult};
1283: }
1284: } else {
1285: if ($crsdef) {
1286: my $reply = &dump_with_regexp(join(":",($cdom,$cnum,$dbname,'','')),$loncaparev);
1287: %ltienc = %{&Apache::lonnet::unserialize($reply)};
1288: } else {
1289: my $reply = &get_dom("getdom:$cdom:$dbname:$name");
1290: my $encref = &Apache::lonnet::thaw_unescape($reply);
1291: if (ref($encref) eq 'HASH') {
1292: %ltienc = %{$encref};
1293: }
1294: }
1295: my $cachetime = 24*60*60;
1296: &Apache::lonnet::do_cache_new($cachename,$hashid,\%ltienc,$cachetime);
1297: }
1298: if (!keys(%ltienc)) {
1299: return ();
1300: } elsif (exists($ltienc{$idx})) {
1301: if (ref($ltienc{$idx}) eq 'HASH') {
1302: if (exists($ltienc{$idx}{'key'})) {
1303: $key = $ltienc{$idx}{'key'};
1304: }
1305: if (exists($ltienc{$idx}{'secret'})) {
1306: $secret = $ltienc{$idx}{'secret'};
1307: if ($keynum =~ /^\d+$/) {
1308: my $privhost;
1309: my $privname = 'ltitools';
1310: if (($type eq 'lti') || ($type eq 'linkprot')) {
1311: $privname = 'lti';
1312: }
1313: if ($crsdef) {
1314: my $primary = &Apache::lonnet::domain($cdom,'primary');
1315: my @ids = &Apache::lonnet::current_machine_ids();
1316: unless (grep(/^\Q$primary\E$/,@ids)) {
1317: $privhost = $primary;
1318: my ($result,$plainsecret) = &decrypt_secret($privhost,$secret,$keynum,$privname);
1319: if ($result eq 'ok') {
1320: $secret = $plainsecret;
1321: } else {
1322: undef($secret);
1323: }
1324: }
1325: }
1326: unless ($privhost) {
1327: my $privkey = &get_dom("getdom:$cdom:private:$keynum:$privname:key");
1328: if (($privkey ne '') && ($secret ne '')) {
1329: my $cipher = new Crypt::CBC($privkey);
1330: $secret = $cipher->decrypt_hex($secret);
1331: } else {
1332: undef($secret);
1333: }
1334: }
1335: }
1336: }
1337: }
1338: }
1339: return ($key,$secret);
1340: }
1341:
1342: sub decrypt_secret {
1343: my ($privhost,$secret,$keynum,$type) = @_;
1344: return;
1345: }
1346:
1.1 droeschl 1347: 1;
1348:
1349: __END__
1350:
1351: =head1 NAME
1352:
1353: LONCAPA::Lond.pm
1354:
1355: =head1 SYNOPSIS
1356:
1357: #TODO
1358:
1359: =head1 DESCRIPTION
1360:
1361: #TODO
1362:
1363: =head1 METHODS
1364:
1365: =over 4
1366:
1.2 droeschl 1367: =item dump_with_regexp( $tail, $client )
1.1 droeschl 1368:
1369: Dump a profile database with an optional regular expression to match against
1370: the keys. In this dump, no effort is made to separate symb from version
1371: information. Presumably the databases that are dumped by this command are of a
1372: different structure. Need to look at this and improve the documentation of
1373: both this and the currentdump handler.
1374:
1375: $tail a colon separated list containing
1376:
1377: =over
1378:
1379: =item domain
1380:
1381: =item user
1382:
1383: identifying the user.
1384:
1385: =item namespace
1386:
1387: identifying the database.
1388:
1389: =item regexp
1390:
1391: optional regular expression that is matched against database keywords to do
1392: selective dumps.
1393:
1394: =item range
1395:
1396: optional range of entries e.g., 10-20 would return the 10th to 19th items, etc.
1397:
1398: =back
1399:
1400: $client is the channel open on the client.
1401:
1402: Returns: 1 (Continue processing).
1403:
1404: Side effects: response is written to $client.
1405:
1.5 bisitz 1406: =item dump_course_id_handler
1.4 droeschl 1407:
1408: #TODO copy from lond
1409:
1410: =item dump_profile_database
1411:
1412: #TODO copy from lond
1.2 droeschl 1413:
1414: =item releasereqd_check( $cnum, $cdom, $key, $value, $major, $minor,
1415: $homecourses, $ids )
1416:
1417: releasereqd_check() will determine if a LON-CAPA version (defined in the
1418: $major,$minor args passed) is not too old to allow use of a role in a
1419: course ($cnum,$cdom args passed), if at least one of the following applies:
1420: (a) the course is a Community, (b) the course's home server is *not* the
1421: current server, or (c) cached course information is not stale.
1422:
1423: For the case where none of these apply, the course is added to the
1424: $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).
1425: The $homecourse hash ref is for courses for which the current server is the
1426: home server. LON-CAPA version requirements are checked elsewhere for the
1427: items in $homecourse.
1428:
1429:
1430: =item check_homecourses( $homecourses, $regexp, $count, $range, $start, $end,
1431: $major, $minor )
1432:
1433: check_homecourses() will retrieve course information for those courses which
1434: are keys of the $homecourses hash ref (first arg). The nohist_courseids.db
1435: GDBM file is tied and course information for each course retrieved. Last
1436: visit (lasttime key) is also retrieved for each, and cached values updated
1437: for any courses last visited less than 24 hours ago. Cached values are also
1438: updated for any courses included in the $homecourses hash ref.
1439:
1440: The reason for the 24 hours constraint is that the cron entry in
1441: /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes
1442: cached course information to be updated nightly for courses with activity
1443: within the past 24 hours.
1444:
1445: Role information for the user (included in a ref to an array of hashes as the
1446: value for each key in $homecourses) is appended to the result returned by the
1447: routine, which will in turn be appended to the string returned to the client
1448: hosting the user's session.
1449:
1450:
1451: =item useable_role( $reqdmajor, $reqdminor, $major, $minor )
1452:
1453: useable_role() will compare the LON-CAPA version required by a course with
1454: the version available on the client server. If the client server's version
1455: is compatible, 1 will be returned.
1456:
1457:
1.3 droeschl 1458: =item get_courseinfo_hash( $cnum, $cdom, $home )
1459:
1460: get_courseinfo_hash() is used to retrieve course information from the db
1461: file: nohist_courseids.db for a course for which the current server is *not*
1462: the home server.
1463:
1464: A hash of a hash will be retrieved. The outer hash contains a single key --
1465: courseID -- for the course for which the data are being requested.
1466: The contents of the inner hash, for that single item in the outer hash
1467: are returned (and cached in memcache for 10 minutes).
1468:
1.8.2.2 raeburn 1469: =item get_dom ( $userinput )
1.3 droeschl 1470:
1.8.2.2 raeburn 1471: get_dom() will retrieve domain configuration information from a GDBM file
1472: in /home/httpd/lonUsers/$dom on the primary library server in a domain.
1473: The single argument passed is the string: $cmd:$udom:$namespace:$what
1474: where $cmd is the command historically passed to lond - i.e., getdom
1475: or egetdom, $udom is the domain, $namespace is the name of the GDBM file
1476: (encconfig or configuration), and $what is a string containing names of
1477: items to retrieve from the db file (each item name is escaped and separated
1478: from the next item name with an ampersand). The return value is either:
1479: error: followed by an error message, or a string containing the value (escaped)
1480: for each item, again separated from the next item with an ampersand.
1.3 droeschl 1481:
1.1 droeschl 1482: =back
1483:
1484: =head1 BUGS
1485:
1486: No known bugs at this time.
1487:
1488: =head1 SEE ALSO
1489:
1490: L<Apache::lonnet>, L<lond>
1491:
1492: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to Lond.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom