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