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