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