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