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