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