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