loncom/lonnet/perl/lonnet.pm - view

File: [LON-CAPA] / loncom / lonnet / perl / lonnet.pm
Revision 1.1419: download - view: text, annotated - select for diffs
Tue Mar 3 01:16:39 2020 UTC (4 years, 4 months ago) by raeburn
Branches: MAIN
CVS tags: HEAD

- URL for external resources in uploaded .page ("Composite page") changed
  to begin /ext/ (but are not wrapped).
- Printouts of external resources include title of item in course, and link
  unless encrypturl is set to yes for the resource.

1: # The LearningOnline Network 2: # TCP networking package 3: # 4: # $Id: lonnet.pm,v 1.1419 2020/03/03 01:16:39 raeburn Exp $ 5: # 6: # Copyright Michigan State University Board of Trustees 7: # 8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 9: # 10: # LON-CAPA is free software; you can redistribute it and/or modify 11: # it under the terms of the GNU General Public License as published by 12: # the Free Software Foundation; either version 2 of the License, or 13: # (at your option) any later version. 14: # 15: # LON-CAPA is distributed in the hope that it will be useful, 16: # but WITHOUT ANY WARRANTY; without even the implied warranty of 17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18: # GNU General Public License for more details. 19: # 20: # You should have received a copy of the GNU General Public License 21: # along with LON-CAPA; if not, write to the Free Software 22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 23: # 24: # /home/httpd/html/adm/gpl.txt 25: # 26: # http://www.lon-capa.org/ 27: # 28: ### 29: 30: =pod 31: 32: =head1 NAME 33: 34: Apache::lonnet.pm 35: 36: =head1 SYNOPSIS 37: 38: This file is an interface to the lonc processes of 39: the LON-CAPA network as well as set of elaborated functions for handling information 40: necessary for navigating through a given cluster of LON-CAPA machines within a 41: domain. There are over 40 specialized functions in this module which handle the 42: reading and transmission of metadata, user information (ids, names, environments, roles, 43: logs), file information (storage, reading, directories, extensions, replication, embedded 44: styles and descriptors), educational resources (course descriptions, section names and 45: numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to 46: and from more descriptive phrases or explanations. 47: 48: This is part of the LearningOnline Network with CAPA project 49: described at http://www.lon-capa.org. 50: 51: =head1 Package Variables 52: 53: These are largely undocumented, so if you decipher one please note it here. 54: 55: =over 4 56: 57: =item $processmarker 58: 59: Contains the time this process was started and this servers host id. 60: 61: =item $dumpcount 62: 63: Counts the number of times a message log flush has been attempted (regardless 64: of success) by this process. Used as part of the filename when messages are 65: delayed. 66: 67: =back 68: 69: =cut 70: 71: package Apache::lonnet; 72: 73: use strict; 74: use HTTP::Date; 75: use Image::Magick; 76: use CGI::Cookie; 77: 78: use Encode; 79: 80: use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex 81: $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease 82: %managerstab $passwdmin); 83: 84: my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, 85: %userrolehash, $processmarker, $dumpcount, %coursedombuf, 86: %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, 87: %courseownerbuf, %coursetypebuf,$locknum); 88: 89: use IO::Socket; 90: use GDBM_File; 91: use HTML::LCParser; 92: use Fcntl qw(:flock); 93: use Storable qw(thaw nfreeze); 94: use Time::HiRes qw( sleep gettimeofday tv_interval ); 95: use Cache::Memcached; 96: use Digest::MD5; 97: use Math::Random; 98: use File::MMagic; 99: use LONCAPA qw(:DEFAULT :match); 100: use LONCAPA::Configuration; 101: use LONCAPA::lonmetadata; 102: use LONCAPA::Lond; 103: use LONCAPA::LWPReq; 104: use LONCAPA::transliterate; 105: 106: use File::Copy; 107: 108: my $readit; 109: my $max_connection_retries = 20; # Or some such value. 110: 111: require Exporter; 112: 113: our @ISA = qw (Exporter); 114: our @EXPORT = qw(%env); 115: 116: 117: # ------------------------------------ Logging (parameters, docs, slots, roles) 118: { 119: my $logid; 120: sub write_log { 121: my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_; 122: if ($context eq 'course') { 123: if (($cnum eq '') || ($cdom eq '')) { 124: $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; 125: $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 126: } 127: } 128: $logid ++; 129: my $now = time(); 130: my $id=$now.'00000'.$$.'00000'.$logid; 131: my $logentry = { 132: $id => { 133: 'exe_uname' => $env{'user.name'}, 134: 'exe_udom' => $env{'user.domain'}, 135: 'exe_time' => $now, 136: 'exe_ip' => $ENV{'REMOTE_ADDR'}, 137: 'delflag' => $delflag, 138: 'logentry' => $storehash, 139: 'uname' => $uname, 140: 'udom' => $udom, 141: } 142: }; 143: return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); 144: } 145: } 146: 147: sub logtouch { 148: my $execdir=$perlvar{'lonDaemons'}; 149: unless (-e "$execdir/logs/lonnet.log") { 150: open(my $fh,">>","$execdir/logs/lonnet.log"); 151: close $fh; 152: } 153: my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; 154: chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log'); 155: } 156: 157: sub logthis { 158: my $message=shift; 159: my $execdir=$perlvar{'lonDaemons'}; 160: my $now=time; 161: my $local=localtime($now); 162: if (open(my $fh,">>","$execdir/logs/lonnet.log")) { 163: my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. 164: print $fh $logstring; 165: close($fh); 166: } 167: return 1; 168: } 169: 170: sub logperm { 171: my $message=shift; 172: my $execdir=$perlvar{'lonDaemons'}; 173: my $now=time; 174: my $local=localtime($now); 175: if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) { 176: print $fh "$now:$message:$local\n"; 177: close($fh); 178: } 179: return 1; 180: } 181: 182: sub create_connection { 183: my ($hostname,$lonid) = @_; 184: my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, 185: Type => SOCK_STREAM, 186: Timeout => 10); 187: return 0 if (!$client); 188: print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n"); 189: my $result = <$client>; 190: chomp($result); 191: return 1 if ($result eq 'done'); 192: return 0; 193: } 194: 195: sub get_server_timezone { 196: my ($cnum,$cdom) = @_; 197: my $home=&homeserver($cnum,$cdom); 198: if ($home ne 'no_host') { 199: my $cachetime = 24*3600; 200: my ($timezone,$cached)=&is_cached_new('servertimezone',$home); 201: if (defined($cached)) { 202: return $timezone; 203: } else { 204: my $timezone = &reply('servertimezone',$home); 205: return &do_cache_new('servertimezone',$home,$timezone,$cachetime); 206: } 207: } 208: } 209: 210: sub get_server_distarch { 211: my ($lonhost,$ignore_cache) = @_; 212: if (defined($lonhost)) { 213: if (!defined(&hostname($lonhost))) { 214: return; 215: } 216: my $cachetime = 12*3600; 217: if (!$ignore_cache) { 218: my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost); 219: if (defined($cached)) { 220: return $distarch; 221: } 222: } 223: my $rep = &reply('serverdistarch',$lonhost); 224: unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || 225: $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' || 226: $rep eq '') { 227: return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime); 228: } 229: } 230: return; 231: } 232: 233: sub get_servercerts_info { 234: my ($lonhost,$hostname,$context) = @_; 235: return if ($lonhost eq ''); 236: if ($hostname eq '') { 237: $hostname = &hostname($lonhost); 238: } 239: return if ($hostname eq ''); 240: my ($rep,$uselocal); 241: if ($context eq 'install') { 242: $uselocal = 1; 243: } elsif (grep { $_ eq $lonhost } &current_machine_ids()) { 244: $uselocal = 1; 245: } 246: if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) { 247: my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; 248: if ($distro eq '') { 249: $uselocal = 0; 250: } elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) { 251: if ($1 < 6) { 252: $uselocal = 0; 253: } 254: } elsif ($distro =~ /^(?:sles)(\d+)$/) { 255: if ($1 < 12) { 256: $uselocal = 0; 257: } 258: } 259: } 260: if ($uselocal) { 261: $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname); 262: } else { 263: $rep=&reply('servercerts',$lonhost); 264: } 265: my ($result,%returnhash); 266: if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || 267: ($rep eq 'unknown_cmd')) { 268: $result = $rep; 269: } else { 270: $result = 'ok'; 271: my @pairs=split(/\&/,$rep); 272: foreach my $item (@pairs) { 273: my ($key,$value)=split(/=/,$item,2); 274: my $what = &unescape($key); 275: $returnhash{$what}=&thaw_unescape($value); 276: } 277: } 278: return ($result,\%returnhash); 279: } 280: 281: sub get_server_loncaparev { 282: my ($dom,$lonhost,$ignore_cache,$caller) = @_; 283: if (defined($lonhost)) { 284: if (!defined(&hostname($lonhost))) { 285: undef($lonhost); 286: } 287: } 288: if (!defined($lonhost)) { 289: if (defined(&domain($dom,'primary'))) { 290: $lonhost=&domain($dom,'primary'); 291: if ($lonhost eq 'no_host') { 292: undef($lonhost); 293: } 294: } 295: } 296: if (defined($lonhost)) { 297: my $cachetime = 12*3600; 298: if (!$ignore_cache) { 299: my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); 300: if (defined($cached)) { 301: return $loncaparev; 302: } 303: } 304: my ($answer,$loncaparev); 305: my @ids=&current_machine_ids(); 306: if (grep(/^\Q$lonhost\E$/,@ids)) { 307: $answer = $perlvar{'lonVersion'}; 308: if ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { 309: $loncaparev = $1; 310: } 311: } else { 312: $answer = &reply('serverloncaparev',$lonhost); 313: if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { 314: if ($caller eq 'loncron') { 315: my $hostname = &hostname($lonhost); 316: my $protocol = $protocol{$lonhost}; 317: $protocol = 'http' if ($protocol ne 'https'); 318: my $url = $protocol.'://'.$hostname.'/adm/about.html'; 319: my $request=new HTTP::Request('GET',$url); 320: my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1); 321: unless ($response->is_error()) { 322: my $content = $response->content; 323: if ($content =~ /VERSION\:\s*([\w.\-]+)<\/p>/) { 324: $loncaparev = $1; 325: } 326: } 327: } else { 328: $loncaparev = $loncaparevs{$lonhost}; 329: } 330: } elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { 331: $loncaparev = $1; 332: } 333: } 334: return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); 335: } 336: } 337: 338: sub get_server_homeID { 339: my ($hostname,$ignore_cache,$caller) = @_; 340: unless ($ignore_cache) { 341: my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname); 342: if (defined($cached)) { 343: return $serverhomeID; 344: } 345: } 346: my $cachetime = 12*3600; 347: my $serverhomeID; 348: if ($caller eq 'loncron') { 349: my @machine_ids = &machine_ids($hostname); 350: foreach my $id (@machine_ids) { 351: my $response = &reply('serverhomeID',$id); 352: unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) { 353: $serverhomeID = $response; 354: last; 355: } 356: } 357: if ($serverhomeID eq '') { 358: $serverhomeID = $machine_ids[-1]; 359: } 360: } else { 361: $serverhomeID = $serverhomeIDs{$hostname}; 362: } 363: return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime); 364: } 365: 366: sub get_remote_globals { 367: my ($lonhost,$whathash,$ignore_cache) = @_; 368: my ($result,%returnhash,%whatneeded); 369: if (ref($whathash) eq 'HASH') { 370: foreach my $what (sort(keys(%{$whathash}))) { 371: my $hashid = $lonhost.'-'.$what; 372: my ($response,$cached); 373: unless ($ignore_cache) { 374: ($response,$cached)=&is_cached_new('lonnetglobal',$hashid); 375: } 376: if (defined($cached)) { 377: $returnhash{$what} = $response; 378: } else { 379: $whatneeded{$what} = 1; 380: } 381: } 382: if (keys(%whatneeded) == 0) { 383: $result = 'ok'; 384: } else { 385: my $requested = &freeze_escape(\%whatneeded); 386: my $rep=&reply('readlonnetglobal:'.$requested,$lonhost); 387: if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || 388: ($rep eq 'unknown_cmd')) { 389: $result = $rep; 390: } else { 391: $result = 'ok'; 392: my @pairs=split(/\&/,$rep); 393: foreach my $item (@pairs) { 394: my ($key,$value)=split(/=/,$item,2); 395: my $what = &unescape($key); 396: my $hashid = $lonhost.'-'.$what; 397: $returnhash{$what}=&thaw_unescape($value); 398: &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600); 399: } 400: } 401: } 402: } 403: return ($result,\%returnhash); 404: } 405: 406: sub remote_devalidate_cache { 407: my ($lonhost,$cachekeys) = @_; 408: my $items; 409: return unless (ref($cachekeys) eq 'ARRAY'); 410: my $cachestr = join('&',@{$cachekeys}); 411: my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost); 412: return $response; 413: } 414: 415: # -------------------------------------------------- Non-critical communication 416: sub subreply { 417: my ($cmd,$server)=@_; 418: my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server); 419: # 420: # With loncnew process trimming, there's a timing hole between lonc server 421: # process exit and the master server picking up the listen on the AF_UNIX 422: # socket. In that time interval, a lock file will exist: 423: 424: my $lockfile=$peerfile.".lock"; 425: while (-e $lockfile) { # Need to wait for the lockfile to disappear. 426: sleep(0.1); 427: } 428: # At this point, either a loncnew parent is listening or an old lonc 429: # or loncnew child is listening so we can connect or everything's dead. 430: # 431: # We'll give the connection a few tries before abandoning it. If 432: # connection is not possible, we'll con_lost back to the client. 433: # 434: my $client; 435: for (my $retries = 0; $retries < $max_connection_retries; $retries++) { 436: $client=IO::Socket::UNIX->new(Peer =>"$peerfile", 437: Type => SOCK_STREAM, 438: Timeout => 10); 439: if ($client) { 440: last; # Connected! 441: } else { 442: &create_connection(&hostname($server),$server); 443: } 444: sleep(0.1); # Try again later if failed connection. 445: } 446: my $answer; 447: if ($client) { 448: print $client "sethost:$server:$cmd\n"; 449: $answer=<$client>; 450: if (!$answer) { $answer="con_lost"; } 451: chomp($answer); 452: } else { 453: $answer = 'con_lost'; # Failed connection. 454: } 455: return $answer; 456: } 457: 458: sub reply { 459: my ($cmd,$server)=@_; 460: unless (defined(&hostname($server))) { return 'no_such_host'; } 461: my $answer=subreply($cmd,$server); 462: if (($answer=~/^refused/) || ($answer=~/^rejected/)) { 463: my $logged = $cmd; 464: if ($cmd =~ /^encrypt:([^:]+):/) { 465: my $subcmd = $1; 466: if (($subcmd eq 'auth') || ($subcmd eq 'passwd') || 467: ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || 468: ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) { 469: (undef,undef,my @rest) = split(/:/,$cmd); 470: if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) { 471: splice(@rest,2,1,'Hidden'); 472: } elsif ($subcmd eq 'passwd') { 473: splice(@rest,2,2,('Hidden','Hidden')); 474: } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || 475: ($subcmd eq 'autoexportgrades')) { 476: splice(@rest,3,1,'Hidden'); 477: } 478: $logged = join(':',('encrypt:'.$subcmd,@rest)); 479: } 480: } 481: &logthis("WARNING:". 482: " $logged to $server returned $answer"); 483: } 484: return $answer; 485: } 486: 487: # ----------------------------------------------------------- Send USR1 to lonc 488: 489: sub reconlonc { 490: my ($lonid) = @_; 491: if ($lonid) { 492: my $hostname = &hostname($lonid); 493: my $peerfile="$perlvar{'lonSockDir'}/$hostname"; 494: if ($hostname && -e $peerfile) { 495: &logthis("Trying to reconnect lonc for $lonid ($hostname)"); 496: my $client=IO::Socket::UNIX->new(Peer => $peerfile, 497: Type => SOCK_STREAM, 498: Timeout => 10); 499: if ($client) { 500: print $client ("reset_retries\n"); 501: my $answer=<$client>; 502: #reset just this one. 503: } 504: } 505: return; 506: } 507: 508: &logthis("Trying to reconnect lonc"); 509: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 510: if (open(my $fh,"<",$loncfile)) { 511: my $loncpid=<$fh>; 512: chomp($loncpid); 513: if (kill 0 => $loncpid) { 514: &logthis("lonc at pid $loncpid responding, sending USR1"); 515: kill USR1 => $loncpid; 516: sleep 1; 517: } else { 518: &logthis( 519: "WARNING:". 520: " lonc at pid $loncpid not responding, giving up"); 521: } 522: } else { 523: &logthis('WARNING: lonc not running, giving up'); 524: } 525: } 526: 527: # ------------------------------------------------------ Critical communication 528: 529: sub critical { 530: my ($cmd,$server)=@_; 531: unless (&hostname($server)) { 532: &logthis("WARNING:". 533: " Critical message to unknown server ($server)"); 534: return 'no_such_host'; 535: } 536: my $answer=reply($cmd,$server); 537: if ($answer eq 'con_lost') { 538: &reconlonc($server); 539: my $answer=reply($cmd,$server); 540: if ($answer eq 'con_lost') { 541: my $now=time; 542: my $middlename=$cmd; 543: $middlename=substr($middlename,0,16); 544: $middlename=~s/\W//g; 545: my $dfilename= 546: "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; 547: $dumpcount++; 548: { 549: my $dfh; 550: if (open($dfh,">",$dfilename)) { 551: print $dfh "$cmd\n"; 552: close($dfh); 553: } 554: } 555: sleep 1; 556: my $wcmd=''; 557: { 558: my $dfh; 559: if (open($dfh,"<",$dfilename)) { 560: $wcmd=<$dfh>; 561: close($dfh); 562: } 563: } 564: chomp($wcmd); 565: if ($wcmd eq $cmd) { 566: &logthis("WARNING: ". 567: "Connection buffer $dfilename: $cmd"); 568: &logperm("D:$server:$cmd"); 569: return 'con_delayed'; 570: } else { 571: &logthis("CRITICAL:" 572: ." Critical connection failed: $server $cmd"); 573: &logperm("F:$server:$cmd"); 574: return 'con_failed'; 575: } 576: } 577: } 578: return $answer; 579: } 580: 581: # ------------------------------------------- check if return value is an error 582: 583: sub error { 584: my ($result) = @_; 585: if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) { 586: if ($2 == 2) { return undef; } 587: return $1; 588: } 589: return undef; 590: } 591: 592: sub convert_and_load_session_env { 593: my ($lonidsdir,$handle)=@_; 594: my @profile; 595: { 596: my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); 597: if (!$opened) { 598: return 0; 599: } 600: flock($idf,LOCK_SH); 601: @profile=<$idf>; 602: close($idf); 603: } 604: my %temp_env; 605: foreach my $line (@profile) { 606: if ($line !~ m/=/) { 607: return 0; 608: } 609: chomp($line); 610: my ($envname,$envvalue)=split(/=/,$line,2); 611: $temp_env{&unescape($envname)} = &unescape($envvalue); 612: } 613: unlink("$lonidsdir/$handle.id"); 614: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(), 615: 0640)) { 616: %disk_env = %temp_env; 617: @env{keys(%temp_env)} = @disk_env{keys(%temp_env)}; 618: untie(%disk_env); 619: } 620: return 1; 621: } 622: 623: # ------------------------------------------- Transfer profile into environment 624: my $env_loaded; 625: sub transfer_profile_to_env { 626: my ($lonidsdir,$handle,$force_transfer) = @_; 627: if (!$force_transfer && $env_loaded) { return; } 628: 629: if (!defined($lonidsdir)) { 630: $lonidsdir = $perlvar{'lonIDsDir'}; 631: } 632: if (!defined($handle)) { 633: ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| ); 634: } 635: 636: my $convert; 637: { 638: my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); 639: if (!$opened) { 640: return; 641: } 642: flock($idf,LOCK_SH); 643: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", 644: &GDBM_READER(),0640)) { 645: @env{keys(%disk_env)} = @disk_env{keys(%disk_env)}; 646: untie(%disk_env); 647: } else { 648: $convert = 1; 649: } 650: } 651: if ($convert) { 652: if (!&convert_and_load_session_env($lonidsdir,$handle)) { 653: &logthis("Failed to load session, or convert session."); 654: } 655: } 656: 657: my %remove; 658: while ( my $envname = each(%env) ) { 659: if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { 660: if ($time < time-300) { 661: $remove{$key}++; 662: } 663: } 664: } 665: 666: $env{'user.environment'} = "$lonidsdir/$handle.id"; 667: $env_loaded=1; 668: foreach my $expired_key (keys(%remove)) { 669: &delenv($expired_key); 670: } 671: } 672: 673: # ---------------------------------------------------- Check for valid session 674: sub check_for_valid_session { 675: my ($r,$name,$userhashref,$domref) = @_; 676: my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); 677: my ($lonidsdir,$linkname,$pubname,$secure,$lonid); 678: if ($name eq 'lonDAV') { 679: $lonidsdir=$r->dir_config('lonDAVsessDir'); 680: } else { 681: $lonidsdir=$r->dir_config('lonIDsDir'); 682: if ($name eq '') { 683: $name = 'lonID'; 684: } 685: } 686: if ($name eq 'lonID') { 687: $secure = 'lonSID'; 688: $linkname = 'lonLinkID'; 689: $pubname = 'lonPubID'; 690: if (exists($cookies{$secure})) { 691: $lonid=$cookies{$secure}; 692: } elsif (exists($cookies{$name})) { 693: $lonid=$cookies{$name}; 694: } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) { 695: $lonid=$cookies{$linkname}; 696: } elsif (exists($cookies{$pubname})) { 697: $lonid=$cookies{$pubname}; 698: } 699: } else { 700: $lonid=$cookies{$name}; 701: } 702: return undef if (!$lonid); 703: 704: my $handle=&LONCAPA::clean_handle($lonid->value); 705: if (-l "$lonidsdir/$handle.id") { 706: my $link = readlink("$lonidsdir/$handle.id"); 707: if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { 708: $handle = $1; 709: } 710: } 711: if (!-e "$lonidsdir/$handle.id") { 712: if ((ref($domref)) && ($name eq 'lonID') && 713: ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { 714: my ($possuname,$possudom,$possuhome) = ($1,$2,$3); 715: if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { 716: $$domref = $possudom; 717: } 718: } 719: return undef; 720: } 721: 722: my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); 723: return undef if (!$opened); 724: 725: flock($idf,LOCK_SH); 726: my %disk_env; 727: if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id", 728: &GDBM_READER(),0640)) { 729: return undef; 730: } 731: 732: if (!defined($disk_env{'user.name'}) 733: || !defined($disk_env{'user.domain'})) { 734: untie(%disk_env); 735: return undef; 736: } 737: 738: if (ref($userhashref) eq 'HASH') { 739: $userhashref->{'name'} = $disk_env{'user.name'}; 740: $userhashref->{'domain'} = $disk_env{'user.domain'}; 741: $userhashref->{'lti'} = $disk_env{'request.lti.login'}; 742: if ($userhashref->{'lti'}) { 743: $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; 744: $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'}; 745: } 746: } 747: untie(%disk_env); 748: 749: return $handle; 750: } 751: 752: sub timed_flock { 753: my ($file,$lock_type) = @_; 754: my $failed=0; 755: eval { 756: local $SIG{__DIE__}='DEFAULT'; 757: local $SIG{ALRM}=sub { 758: $failed=1; 759: die("failed lock"); 760: }; 761: alarm(13); 762: flock($file,$lock_type); 763: alarm(0); 764: }; 765: if ($failed) { 766: return undef; 767: } else { 768: return 1; 769: } 770: } 771: 772: sub get_sessionfile_vars { 773: my ($handle,$lonidsdir,$storearr) = @_; 774: my %returnhash; 775: unless (ref($storearr) eq 'ARRAY') { 776: return %returnhash; 777: } 778: if (-l "$lonidsdir/$handle.id") { 779: my $link = readlink("$lonidsdir/$handle.id"); 780: if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { 781: $handle = $1; 782: } 783: } 784: if ((-e "$lonidsdir/$handle.id") && 785: ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { 786: my ($possuname,$possudom,$possuhome) = ($1,$2,$3); 787: if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { 788: if (open(my $idf,'+<',"$lonidsdir/$handle.id")) { 789: flock($idf,LOCK_SH); 790: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", 791: &GDBM_READER(),0640)) { 792: foreach my $item (@{$storearr}) { 793: $returnhash{$item} = $disk_env{$item}; 794: } 795: untie(%disk_env); 796: } 797: } 798: } 799: } 800: return %returnhash; 801: } 802: 803: # ---------------------------------------------------------- Append Environment 804: 805: sub appenv { 806: my ($newenv,$roles) = @_; 807: if (ref($newenv) eq 'HASH') { 808: foreach my $key (keys(%{$newenv})) { 809: my $refused = 0; 810: if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) { 811: $refused = 1; 812: if (ref($roles) eq 'ARRAY') { 813: my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./}); 814: if (grep(/^\Q$role\E$/,@{$roles})) { 815: $refused = 0; 816: } 817: } 818: } 819: if ($refused) { 820: &logthis("WARNING: ". 821: "Attempt to modify environment ".$key." to ".$newenv->{$key} 822: .''); 823: delete($newenv->{$key}); 824: } else { 825: $env{$key}=$newenv->{$key}; 826: } 827: } 828: my $lonids = $perlvar{'lonIDsDir'}; 829: if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) { 830: my $opened = open(my $env_file,'+<',$env{'user.environment'}); 831: if ($opened 832: && &timed_flock($env_file,LOCK_EX) 833: && 834: tie(my %disk_env,'GDBM_File',$env{'user.environment'}, 835: (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { 836: while (my ($key,$value) = each(%{$newenv})) { 837: $disk_env{$key} = $value; 838: } 839: untie(%disk_env); 840: } 841: } 842: } 843: return 'ok'; 844: } 845: # ----------------------------------------------------- Delete from Environment 846: 847: sub delenv { 848: my ($delthis,$regexp,$roles) = @_; 849: if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) { 850: my $refused = 1; 851: if (ref($roles) eq 'ARRAY') { 852: my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./); 853: if (grep(/^\Q$role\E$/,@{$roles})) { 854: $refused = 0; 855: } 856: } 857: if ($refused) { 858: &logthis("WARNING: ". 859: "Attempt to delete from environment ".$delthis); 860: return 'error'; 861: } 862: } 863: my $opened = open(my $env_file,'+<',$env{'user.environment'}); 864: if ($opened 865: && &timed_flock($env_file,LOCK_EX) 866: && 867: tie(my %disk_env,'GDBM_File',$env{'user.environment'}, 868: (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { 869: foreach my $key (keys(%disk_env)) { 870: if ($regexp) { 871: if ($key=~/^$delthis/) { 872: delete($env{$key}); 873: delete($disk_env{$key}); 874: } 875: } else { 876: if ($key=~/^\Q$delthis\E/) { 877: delete($env{$key}); 878: delete($disk_env{$key}); 879: } 880: } 881: } 882: untie(%disk_env); 883: } 884: return 'ok'; 885: } 886: 887: sub get_env_multiple { 888: my ($name) = @_; 889: my @values; 890: if (defined($env{$name})) { 891: # exists is it an array 892: if (ref($env{$name})) { 893: @values=@{ $env{$name} }; 894: } else { 895: $values[0]=$env{$name}; 896: } 897: } 898: return(@values); 899: } 900: 901: # ------------------------------------------------------------------- Locking 902: 903: sub set_lock { 904: my ($text)=@_; 905: $locknum++; 906: my $id=$$.'-'.$locknum; 907: &appenv({'session.locks' => $env{'session.locks'}.','.$id, 908: 'session.lock.'.$id => $text}); 909: return $id; 910: } 911: 912: sub get_locks { 913: my $num=0; 914: my %texts=(); 915: foreach my $lock (split(/\,/,$env{'session.locks'})) { 916: if ($lock=~/\w/) { 917: $num++; 918: $texts{$lock}=$env{'session.lock.'.$lock}; 919: } 920: } 921: return ($num,%texts); 922: } 923: 924: sub remove_lock { 925: my ($id)=@_; 926: my $newlocks=''; 927: foreach my $lock (split(/\,/,$env{'session.locks'})) { 928: if (($lock=~/\w/) && ($lock ne $id)) { 929: $newlocks.=','.$lock; 930: } 931: } 932: &appenv({'session.locks' => $newlocks}); 933: &delenv('session.lock.'.$id); 934: } 935: 936: sub remove_all_locks { 937: my $activelocks=$env{'session.locks'}; 938: foreach my $lock (split(/\,/,$env{'session.locks'})) { 939: if ($lock=~/\w/) { 940: &remove_lock($lock); 941: } 942: } 943: } 944: 945: 946: # ------------------------------------------ Find out current server userload 947: sub userload { 948: my $numusers=0; 949: { 950: opendir(LONIDS,$perlvar{'lonIDsDir'}); 951: my $filename; 952: my $curtime=time; 953: while ($filename=readdir(LONIDS)) { 954: next if ($filename eq '.' || $filename eq '..'); 955: next if ($filename =~ /publicuser_\d+\.id/); 956: next if ($filename =~ /^[a-f0-9]+_linked\.id$/); 957: my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; 958: if ($curtime-$mtime < 1800) { $numusers++; } 959: } 960: closedir(LONIDS); 961: } 962: my $userloadpercent=0; 963: my $maxuserload=$perlvar{'lonUserLoadLim'}; 964: if ($maxuserload) { 965: $userloadpercent=100*$numusers/$maxuserload; 966: } 967: $userloadpercent=sprintf("%.2f",$userloadpercent); 968: return $userloadpercent; 969: } 970: 971: # ------------------------------ Find server with least workload from spare.tab 972: 973: sub spareserver { 974: my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_; 975: my $spare_server; 976: if ($userloadpercent !~ /\d/) { $userloadpercent=0; } 977: my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 978: : $userloadpercent; 979: my ($uint_dom,$remotesessions); 980: if (($udom ne '') && (&domain($udom) ne '')) { 981: my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); 982: $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); 983: my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); 984: $remotesessions = $udomdefaults{'remotesessions'}; 985: } 986: my $spareshash = &this_host_spares($udom); 987: if (ref($spareshash) eq 'HASH') { 988: if (ref($spareshash->{'primary'}) eq 'ARRAY') { 989: foreach my $try_server (@{ $spareshash->{'primary'} }) { 990: next unless (&spare_can_host($udom,$uint_dom,$remotesessions, 991: $try_server)); 992: ($spare_server, $lowest_load) = 993: &compare_server_load($try_server, $spare_server, $lowest_load); 994: } 995: } 996: 997: my $found_server = ($spare_server ne '' && $lowest_load < 100); 998: 999: if (!$found_server) { 1000: if (ref($spareshash->{'default'}) eq 'ARRAY') { 1001: foreach my $try_server (@{ $spareshash->{'default'} }) { 1002: next unless (&spare_can_host($udom,$uint_dom, 1003: $remotesessions,$try_server)); 1004: ($spare_server, $lowest_load) = 1005: &compare_server_load($try_server, $spare_server, $lowest_load); 1006: } 1007: } 1008: } 1009: } 1010: 1011: if (!$want_server_name) { 1012: if (defined($spare_server)) { 1013: my $hostname = &hostname($spare_server); 1014: if (defined($hostname)) { 1015: my $protocol = 'http'; 1016: if ($protocol{$spare_server} eq 'https') { 1017: $protocol = $protocol{$spare_server}; 1018: } 1019: $spare_server = $protocol.'://'.$hostname; 1020: } 1021: } 1022: } 1023: return $spare_server; 1024: } 1025: 1026: sub compare_server_load { 1027: my ($try_server, $spare_server, $lowest_load, $required) = @_; 1028: 1029: if ($required) { 1030: my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/); 1031: my $remoterev = &get_server_loncaparev(undef,$try_server); 1032: my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); 1033: if (($major eq '' && $minor eq '') || 1034: (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) { 1035: return ($spare_server,$lowest_load); 1036: } 1037: } 1038: 1039: my $loadans = &reply('load', $try_server); 1040: my $userloadans = &reply('userload',$try_server); 1041: 1042: if ($loadans !~ /\d/ && $userloadans !~ /\d/) { 1043: return ($spare_server, $lowest_load); #didn't get a number from the server 1044: } 1045: 1046: my $load; 1047: if ($loadans =~ /\d/) { 1048: if ($userloadans =~ /\d/) { 1049: #both are numbers, pick the bigger one 1050: $load = ($loadans > $userloadans) ? $loadans 1051: : $userloadans; 1052: } else { 1053: $load = $loadans; 1054: } 1055: } else { 1056: $load = $userloadans; 1057: } 1058: 1059: if (($load =~ /\d/) && ($load < $lowest_load)) { 1060: $spare_server = $try_server; 1061: $lowest_load = $load; 1062: } 1063: return ($spare_server,$lowest_load); 1064: } 1065: 1066: # --------------------------- ask offload servers if user already has a session 1067: sub find_existing_session { 1068: my ($udom,$uname) = @_; 1069: my $spareshash = &this_host_spares($udom); 1070: if (ref($spareshash) eq 'HASH') { 1071: if (ref($spareshash->{'primary'}) eq 'ARRAY') { 1072: foreach my $try_server (@{ $spareshash->{'primary'} }) { 1073: return $try_server if (&has_user_session($try_server, $udom, $uname)); 1074: } 1075: } 1076: if (ref($spareshash->{'default'}) eq 'ARRAY') { 1077: foreach my $try_server (@{ $spareshash->{'default'} }) { 1078: return $try_server if (&has_user_session($try_server, $udom, $uname)); 1079: } 1080: } 1081: } 1082: return; 1083: } 1084: 1085: sub delusersession { 1086: my ($lonid,$udom,$uname) = @_; 1087: my $uprimary_id = &domain($udom,'primary'); 1088: my $uintdom = &internet_dom($uprimary_id); 1089: my $intdom = &internet_dom($lonid); 1090: my $serverhomedom = &host_domain($lonid); 1091: if (($uintdom ne '') && ($uintdom eq $intdom)) { 1092: return &reply(join(':','delusersession', 1093: map {&escape($_)} ($udom,$uname)),$lonid); 1094: } 1095: return; 1096: } 1097: 1098: # check if user's browser sent load balancer cookie and server still has session 1099: # and is not overloaded. 1100: sub check_for_balancer_cookie { 1101: my ($r,$update_mtime) = @_; 1102: my ($otherserver,$cookie); 1103: my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); 1104: if (exists($cookies{'balanceID'})) { 1105: my $balid = $cookies{'balanceID'}; 1106: $cookie=&LONCAPA::clean_handle($balid->value); 1107: my $balancedir=$r->dir_config('lonBalanceDir'); 1108: if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) { 1109: if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) { 1110: my ($possudom,$possuname) = ($1,$2); 1111: my $has_session = 0; 1112: if ((&domain($possudom) ne '') && 1113: (&homeserver($possuname,$possudom) ne 'no_host')) { 1114: my $try_server; 1115: my $opened = open(my $idf,'+<',"$balancedir/$cookie.id"); 1116: if ($opened) { 1117: flock($idf,LOCK_SH); 1118: while (my $line = <$idf>) { 1119: chomp($line); 1120: if (&hostname($line) ne '') { 1121: $try_server = $line; 1122: last; 1123: } 1124: } 1125: close($idf); 1126: if (($try_server) && 1127: (&has_user_session($try_server,$possudom,$possuname))) { 1128: my $lowest_load = 30000; 1129: ($otherserver,$lowest_load) = 1130: &compare_server_load($try_server,undef,$lowest_load); 1131: if ($otherserver ne '' && $lowest_load < 100) { 1132: $has_session = 1; 1133: } else { 1134: undef($otherserver); 1135: } 1136: } 1137: } 1138: } 1139: if ($has_session) { 1140: if ($update_mtime) { 1141: my $atime = my $mtime = time; 1142: utime($atime,$mtime,"$balancedir/$cookie.id"); 1143: } 1144: } else { 1145: unlink("$balancedir/$cookie.id"); 1146: } 1147: } 1148: } 1149: } 1150: return ($otherserver,$cookie); 1151: } 1152: 1153: sub delbalcookie { 1154: my ($cookie,$balancer) =@_; 1155: if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { 1156: my ($udom,$uname) = ($1,$2); 1157: my $uprimary_id = &domain($udom,'primary'); 1158: my $uintdom = &internet_dom($uprimary_id); 1159: my $intdom = &internet_dom($balancer); 1160: my $serverhomedom = &host_domain($balancer); 1161: if (($uintdom ne '') && ($uintdom eq $intdom)) { 1162: return &reply("delbalcookie:$cookie",$balancer); 1163: } 1164: } 1165: } 1166: 1167: # -------------------------------- ask if server already has a session for user 1168: sub has_user_session { 1169: my ($lonid,$udom,$uname) = @_; 1170: my $result = &reply(join(':','userhassession', 1171: map {&escape($_)} ($udom,$uname)),$lonid); 1172: return 1 if ($result eq 'ok'); 1173: 1174: return 0; 1175: } 1176: 1177: # --------- determine least loaded server in a user's domain which allows login 1178: 1179: sub choose_server { 1180: my ($udom,$checkloginvia,$required,$skiploadbal) = @_; 1181: my %domconfhash = &Apache::loncommon::get_domainconf($udom); 1182: my %servers = &get_servers($udom); 1183: my $lowest_load = 30000; 1184: my ($login_host,$hostname,$portal_path,$isredirect,$balancers); 1185: if ($skiploadbal) { 1186: ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom); 1187: unless (defined($cached)) { 1188: my $cachetime = 60*60*24; 1189: my %domconfig = 1190: &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom); 1191: if (ref($domconfig{'loadbalancing'}) eq 'HASH') { 1192: $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'}, 1193: $cachetime); 1194: } 1195: } 1196: } 1197: foreach my $lonhost (keys(%servers)) { 1198: if ($skiploadbal) { 1199: if (ref($balancers) eq 'HASH') { 1200: next if (exists($balancers->{$lonhost})); 1201: } 1202: } 1203: my $loginvia; 1204: if ($checkloginvia) { 1205: $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; 1206: if ($loginvia) { 1207: my ($server,$path) = split(/:/,$loginvia); 1208: ($login_host, $lowest_load) = 1209: &compare_server_load($server, $login_host, $lowest_load, $required); 1210: if ($login_host eq $server) { 1211: $portal_path = $path; 1212: $isredirect = 1; 1213: } 1214: } else { 1215: ($login_host, $lowest_load) = 1216: &compare_server_load($lonhost, $login_host, $lowest_load, $required); 1217: if ($login_host eq $lonhost) { 1218: $portal_path = ''; 1219: $isredirect = ''; 1220: } 1221: } 1222: } else { 1223: ($login_host, $lowest_load) = 1224: &compare_server_load($lonhost, $login_host, $lowest_load, $required); 1225: } 1226: } 1227: if ($login_host ne '') { 1228: $hostname = &hostname($login_host); 1229: } 1230: return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); 1231: } 1232: 1233: # --------------------------------------------- Try to change a user's password 1234: 1235: sub changepass { 1236: my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; 1237: $currentpass = &escape($currentpass); 1238: $newpass = &escape($newpass); 1239: my $lonhost = $perlvar{'lonHostID'}; 1240: my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost", 1241: $server); 1242: if (! $answer) { 1243: &logthis("No reply on password change request to $server ". 1244: "by $uname in domain $udom."); 1245: } elsif ($answer =~ "^ok") { 1246: &logthis("$uname in $udom successfully changed their password ". 1247: "on $server."); 1248: } elsif ($answer =~ "^pwchange_failure") { 1249: &logthis("$uname in $udom was unable to change their password ". 1250: "on $server. The action was blocked by either lcpasswd ". 1251: "or pwchange"); 1252: } elsif ($answer =~ "^non_authorized") { 1253: &logthis("$uname in $udom did not get their password correct when ". 1254: "attempting to change it on $server."); 1255: } elsif ($answer =~ "^auth_mode_error") { 1256: &logthis("$uname in $udom attempted to change their password despite ". 1257: "not being locally or internally authenticated on $server."); 1258: } elsif ($answer =~ "^unknown_user") { 1259: &logthis("$uname in $udom attempted to change their password ". 1260: "on $server but were unable to because $server is not ". 1261: "their home server."); 1262: } elsif ($answer =~ "^refused") { 1263: &logthis("$server refused to change $uname in $udom password because ". 1264: "it was sent an unencrypted request to change the password."); 1265: } elsif ($answer =~ "invalid_client") { 1266: &logthis("$server refused to change $uname in $udom password because ". 1267: "it was a reset by e-mail originating from an invalid server."); 1268: } elsif ($answer =~ "^prioruse") { 1269: &logthis("$server refused to change $uname in $udom password because ". 1270: "the password had been used before"); 1271: } 1272: return $answer; 1273: } 1274: 1275: # ----------------------- Try to determine user's current authentication scheme 1276: 1277: sub queryauthenticate { 1278: my ($uname,$udom)=@_; 1279: my $uhome=&homeserver($uname,$udom); 1280: if (!$uhome) { 1281: &logthis("User $uname at $udom is unknown when looking for authentication mechanism"); 1282: return 'no_host'; 1283: } 1284: my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome); 1285: if ($answer =~ /^(unknown_user|refused|con_lost)/) { 1286: &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); 1287: } 1288: return $answer; 1289: } 1290: 1291: # --------- Try to authenticate user from domain's lib servers (first this one) 1292: 1293: sub authenticate { 1294: my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_; 1295: $upass=&escape($upass); 1296: $uname= &LONCAPA::clean_username($uname); 1297: my $uhome=&homeserver($uname,$udom,1); 1298: my $newhome; 1299: if ((!$uhome) || ($uhome eq 'no_host')) { 1300: # Maybe the machine was offline and only re-appeared again recently? 1301: &reconlonc(); 1302: # One more 1303: $uhome=&homeserver($uname,$udom,1); 1304: if (($uhome eq 'no_host') && $checkdefauth) { 1305: if (defined(&domain($udom,'primary'))) { 1306: $newhome=&domain($udom,'primary'); 1307: } 1308: if ($newhome ne '') { 1309: $uhome = $newhome; 1310: } 1311: } 1312: if ((!$uhome) || ($uhome eq 'no_host')) { 1313: &logthis("User $uname at $udom is unknown in authenticate"); 1314: return 'no_host'; 1315: } 1316: } 1317: my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome); 1318: if ($answer eq 'authorized') { 1319: if ($newhome) { 1320: &logthis("User $uname at $udom authorized by $uhome, but needs account"); 1321: return 'no_account_on_host'; 1322: } else { 1323: &logthis("User $uname at $udom authorized by $uhome"); 1324: return $uhome; 1325: } 1326: } 1327: if ($answer eq 'non_authorized') { 1328: &logthis("User $uname at $udom rejected by $uhome"); 1329: return 'no_host'; 1330: } 1331: &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); 1332: return 'no_host'; 1333: } 1334: 1335: sub can_host_session { 1336: my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_; 1337: my $canhost = 1; 1338: my $host_idn = &Apache::lonnet::internet_dom($lonhost); 1339: if (ref($remotesessions) eq 'HASH') { 1340: if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') { 1341: if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) { 1342: $canhost = 0; 1343: } else { 1344: $canhost = 1; 1345: } 1346: } 1347: if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') { 1348: if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) { 1349: $canhost = 1; 1350: } else { 1351: $canhost = 0; 1352: } 1353: } 1354: if ($canhost) { 1355: if ($remotesessions->{'version'} ne '') { 1356: my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/); 1357: if ($reqmajor ne '' && $reqminor ne '') { 1358: if ($remoterev =~ /^\'?(\d+)\.(\d+)/) { 1359: my $major = $1; 1360: my $minor = $2; 1361: if (($major < $reqmajor ) || 1362: (($major == $reqmajor) && ($minor < $reqminor))) { 1363: $canhost = 0; 1364: } 1365: } else { 1366: $canhost = 0; 1367: } 1368: } 1369: } 1370: } 1371: } 1372: if ($canhost) { 1373: if (ref($hostedsessions) eq 'HASH') { 1374: my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); 1375: my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); 1376: if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { 1377: if (($uint_dom ne '') && 1378: (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) { 1379: $canhost = 0; 1380: } else { 1381: $canhost = 1; 1382: } 1383: } 1384: if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { 1385: if (($uint_dom ne '') && 1386: (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) { 1387: $canhost = 1; 1388: } else { 1389: $canhost = 0; 1390: } 1391: } 1392: } 1393: } 1394: return $canhost; 1395: } 1396: 1397: sub spare_can_host { 1398: my ($udom,$uint_dom,$remotesessions,$try_server)=@_; 1399: my $canhost=1; 1400: my $try_server_hostname = &hostname($try_server); 1401: my $serverhomeID = &get_server_homeID($try_server_hostname); 1402: my $serverhomedom = &host_domain($serverhomeID); 1403: my %defdomdefaults = &get_domain_defaults($serverhomedom); 1404: if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') { 1405: if ($defdomdefaults{'offloadnow'}{$try_server}) { 1406: $canhost = 0; 1407: } 1408: } 1409: if (($canhost) && ($uint_dom)) { 1410: my @intdoms; 1411: my $internet_names = &get_internet_names($try_server); 1412: if (ref($internet_names) eq 'ARRAY') { 1413: @intdoms = @{$internet_names}; 1414: } 1415: unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { 1416: my $remoterev = &get_server_loncaparev(undef,$try_server); 1417: $canhost = &can_host_session($udom,$try_server,$remoterev, 1418: $remotesessions, 1419: $defdomdefaults{'hostedsessions'}); 1420: } 1421: } 1422: return $canhost; 1423: } 1424: 1425: sub this_host_spares { 1426: my ($dom) = @_; 1427: my ($dom_in_use,$lonhost_in_use,$result); 1428: my @hosts = &current_machine_ids(); 1429: foreach my $lonhost (@hosts) { 1430: if (&host_domain($lonhost) eq $dom) { 1431: $dom_in_use = $dom; 1432: $lonhost_in_use = $lonhost; 1433: last; 1434: } 1435: } 1436: if ($dom_in_use ne '') { 1437: $result = &spares_for_offload($dom_in_use,$lonhost_in_use); 1438: } 1439: if (ref($result) ne 'HASH') { 1440: $lonhost_in_use = $perlvar{'lonHostID'}; 1441: $dom_in_use = &host_domain($lonhost_in_use); 1442: $result = &spares_for_offload($dom_in_use,$lonhost_in_use); 1443: if (ref($result) ne 'HASH') { 1444: $result = \%spareid; 1445: } 1446: } 1447: return $result; 1448: } 1449: 1450: sub spares_for_offload { 1451: my ($dom_in_use,$lonhost_in_use) = @_; 1452: my ($result,$cached)=&is_cached_new('spares',$dom_in_use); 1453: if (defined($cached)) { 1454: return $result; 1455: } else { 1456: my $cachetime = 60*60*24; 1457: my %domconfig = 1458: &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use); 1459: if (ref($domconfig{'usersessions'}) eq 'HASH') { 1460: if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') { 1461: if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') { 1462: return &do_cache_new('spares',$dom_in_use,$domconfig{'usersessions'}{'spares'}{$lonhost_in_use},$cachetime); 1463: } 1464: } 1465: } 1466: } 1467: return; 1468: } 1469: 1470: sub get_lonbalancer_config { 1471: my ($servers) = @_; 1472: my ($currbalancer,$currtargets); 1473: if (ref($servers) eq 'HASH') { 1474: foreach my $server (keys(%{$servers})) { 1475: my %what = ( 1476: spareid => 1, 1477: perlvar => 1, 1478: ); 1479: my ($result,$returnhash) = &get_remote_globals($server,\%what); 1480: if ($result eq 'ok') { 1481: if (ref($returnhash) eq 'HASH') { 1482: if (ref($returnhash->{'perlvar'}) eq 'HASH') { 1483: if ($returnhash->{'perlvar'}->{'lonBalancer'} eq 'yes') { 1484: $currbalancer = $server; 1485: $currtargets = {}; 1486: if (ref($returnhash->{'spareid'}) eq 'HASH') { 1487: if (ref($returnhash->{'spareid'}->{'primary'}) eq 'ARRAY') { 1488: $currtargets->{'primary'} = $returnhash->{'spareid'}->{'primary'}; 1489: } 1490: if (ref($returnhash->{'spareid'}->{'default'}) eq 'ARRAY') { 1491: $currtargets->{'default'} = $returnhash->{'spareid'}->{'default'}; 1492: } 1493: } 1494: last; 1495: } 1496: } 1497: } 1498: } 1499: } 1500: } 1501: return ($currbalancer,$currtargets); 1502: } 1503: 1504: sub check_loadbalancing { 1505: my ($uname,$udom,$caller) = @_; 1506: my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, 1507: $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers); 1508: my $lonhost = $perlvar{'lonHostID'}; 1509: my @hosts = &current_machine_ids(); 1510: my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); 1511: my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); 1512: my $intdom = &Apache::lonnet::internet_dom($lonhost); 1513: my $serverhomedom = &host_domain($lonhost); 1514: my $domneedscache; 1515: my $cachetime = 60*60*24; 1516: 1517: if (($uintdom ne '') && ($uintdom eq $intdom)) { 1518: $dom_in_use = $udom; 1519: $homeintdom = 1; 1520: } else { 1521: $dom_in_use = $serverhomedom; 1522: } 1523: my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use); 1524: unless (defined($cached)) { 1525: my %domconfig = 1526: &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use); 1527: if (ref($domconfig{'loadbalancing'}) eq 'HASH') { 1528: $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); 1529: } else { 1530: $domneedscache = $dom_in_use; 1531: } 1532: } 1533: if (ref($result) eq 'HASH') { 1534: ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) = 1535: &check_balancer_result($result,@hosts); 1536: if ($is_balancer) { 1537: if (ref($currrules) eq 'HASH') { 1538: if ($homeintdom) { 1539: if ($uname ne '') { 1540: if (($currrules->{'_LC_adv'} ne '') || ($currrules->{'_LC_author'} ne '')) { 1541: my ($is_adv,$is_author) = &is_advanced_user($udom,$uname); 1542: if (($currrules->{'_LC_author'} ne '') && ($is_author)) { 1543: $rule_in_effect = $currrules->{'_LC_author'}; 1544: } elsif (($currrules->{'_LC_adv'} ne '') && ($is_adv)) { 1545: $rule_in_effect = $currrules->{'_LC_adv'} 1546: } 1547: } 1548: if ($rule_in_effect eq '') { 1549: my %userenv = &userenvironment($udom,$uname,'inststatus'); 1550: if ($userenv{'inststatus'} ne '') { 1551: my @statuses = map { &unescape($_); } split(/:/,$userenv{'inststatus'}); 1552: my ($othertitle,$usertypes,$types) = 1553: &Apache::loncommon::sorted_inst_types($udom); 1554: if (ref($types) eq 'ARRAY') { 1555: foreach my $type (@{$types}) { 1556: if (grep(/^\Q$type\E$/,@statuses)) { 1557: if (exists($currrules->{$type})) { 1558: $rule_in_effect = $currrules->{$type}; 1559: } 1560: } 1561: } 1562: } 1563: } else { 1564: if (exists($currrules->{'default'})) { 1565: $rule_in_effect = $currrules->{'default'}; 1566: } 1567: } 1568: } 1569: } else { 1570: if (exists($currrules->{'default'})) { 1571: $rule_in_effect = $currrules->{'default'}; 1572: } 1573: } 1574: } else { 1575: if ($currrules->{'_LC_external'} ne '') { 1576: $rule_in_effect = $currrules->{'_LC_external'}; 1577: } 1578: } 1579: $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets, 1580: $uname,$udom); 1581: } 1582: } 1583: } elsif (($homeintdom) && ($udom ne $serverhomedom)) { 1584: ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom); 1585: unless (defined($cached)) { 1586: my %domconfig = 1587: &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); 1588: if (ref($domconfig{'loadbalancing'}) eq 'HASH') { 1589: $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime); 1590: } else { 1591: $domneedscache = $serverhomedom; 1592: } 1593: } 1594: if (ref($result) eq 'HASH') { 1595: ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) = 1596: &check_balancer_result($result,@hosts); 1597: if ($is_balancer) { 1598: if (ref($currrules) eq 'HASH') { 1599: if ($currrules->{'_LC_internetdom'} ne '') { 1600: $rule_in_effect = $currrules->{'_LC_internetdom'}; 1601: } 1602: } 1603: $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets, 1604: $uname,$udom); 1605: } 1606: } else { 1607: if ($perlvar{'lonBalancer'} eq 'yes') { 1608: $is_balancer = 1; 1609: $offloadto = &this_host_spares($dom_in_use); 1610: } 1611: unless (defined($cached)) { 1612: $domneedscache = $serverhomedom; 1613: } 1614: } 1615: } else { 1616: if ($perlvar{'lonBalancer'} eq 'yes') { 1617: $is_balancer = 1; 1618: $offloadto = &this_host_spares($dom_in_use); 1619: } 1620: unless (defined($cached)) { 1621: $domneedscache = $serverhomedom; 1622: } 1623: } 1624: if ($domneedscache) { 1625: &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); 1626: } 1627: if ($is_balancer) { 1628: my $lowest_load = 30000; 1629: if (ref($offloadto) eq 'HASH') { 1630: if (ref($offloadto->{'primary'}) eq 'ARRAY') { 1631: foreach my $try_server (@{$offloadto->{'primary'}}) { 1632: ($otherserver,$lowest_load) = 1633: &compare_server_load($try_server,$otherserver,$lowest_load); 1634: } 1635: } 1636: my $found_server = ($otherserver ne '' && $lowest_load < 100); 1637: 1638: if (!$found_server) { 1639: if (ref($offloadto->{'default'}) eq 'ARRAY') { 1640: foreach my $try_server (@{$offloadto->{'default'}}) { 1641: ($otherserver,$lowest_load) = 1642: &compare_server_load($try_server,$otherserver,$lowest_load); 1643: } 1644: } 1645: } 1646: } elsif (ref($offloadto) eq 'ARRAY') { 1647: if (@{$offloadto} == 1) { 1648: $otherserver = $offloadto->[0]; 1649: } elsif (@{$offloadto} > 1) { 1650: foreach my $try_server (@{$offloadto}) { 1651: ($otherserver,$lowest_load) = 1652: &compare_server_load($try_server,$otherserver,$lowest_load); 1653: } 1654: } 1655: } 1656: unless ($caller eq 'login') { 1657: if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { 1658: $is_balancer = 0; 1659: if ($uname ne '' && $udom ne '') { 1660: if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { 1661: &appenv({'user.loadbalexempt' => $lonhost, 1662: 'user.loadbalcheck.time' => time}); 1663: } 1664: } 1665: } 1666: } 1667: unless ($homeintdom) { 1668: undef($setcookie); 1669: } 1670: } 1671: return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers); 1672: } 1673: 1674: sub check_balancer_result { 1675: my ($result,@hosts) = @_; 1676: my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); 1677: if (ref($result) eq 'HASH') { 1678: if ($result->{'lonhost'} ne '') { 1679: my $currbalancer = $result->{'lonhost'}; 1680: if (grep(/^\Q$currbalancer\E$/,@hosts)) { 1681: $is_balancer = 1; 1682: $currtargets = $result->{'targets'}; 1683: $currrules = $result->{'rules'}; 1684: } 1685: $dom_balancers = $currbalancer; 1686: } else { 1687: if (keys(%{$result})) { 1688: foreach my $key (keys(%{$result})) { 1689: if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) && 1690: (ref($result->{$key}) eq 'HASH')) { 1691: $is_balancer = 1; 1692: $currrules = $result->{$key}{'rules'}; 1693: $currtargets = $result->{$key}{'targets'}; 1694: $setcookie = $result->{$key}{'cookie'}; 1695: last; 1696: } 1697: } 1698: $dom_balancers = join(',',sort(keys(%{$result}))); 1699: } 1700: } 1701: } 1702: return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); 1703: } 1704: 1705: sub get_loadbalancer_targets { 1706: my ($rule_in_effect,$currtargets,$uname,$udom) = @_; 1707: my $offloadto; 1708: if ($rule_in_effect eq 'none') { 1709: return [$perlvar{'lonHostID'}]; 1710: } elsif ($rule_in_effect eq '') { 1711: $offloadto = $currtargets; 1712: } else { 1713: if ($rule_in_effect eq 'homeserver') { 1714: my $homeserver = &homeserver($uname,$udom); 1715: if ($homeserver ne 'no_host') { 1716: $offloadto = [$homeserver]; 1717: } 1718: } elsif ($rule_in_effect eq 'externalbalancer') { 1719: my %domconfig = 1720: &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom); 1721: if (ref($domconfig{'loadbalancing'}) eq 'HASH') { 1722: if ($domconfig{'loadbalancing'}{'lonhost'} ne '') { 1723: if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') { 1724: $offloadto = [$domconfig{'loadbalancing'}{'lonhost'}]; 1725: } 1726: } 1727: } else { 1728: my %servers = &internet_dom_servers($udom); 1729: my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers); 1730: if (&hostname($remotebalancer) ne '') { 1731: $offloadto = [$remotebalancer]; 1732: } 1733: } 1734: } elsif (&hostname($rule_in_effect) ne '') { 1735: $offloadto = [$rule_in_effect]; 1736: } 1737: } 1738: return $offloadto; 1739: } 1740: 1741: sub internet_dom_servers { 1742: my ($dom) = @_; 1743: my (%uniqservers,%servers); 1744: my $primaryserver = &hostname(&domain($dom,'primary')); 1745: my @machinedoms = &machine_domains($primaryserver); 1746: foreach my $mdom (@machinedoms) { 1747: my %currservers = %servers; 1748: my %server = &get_servers($mdom); 1749: %servers = (%currservers,%server); 1750: } 1751: my %by_hostname; 1752: foreach my $id (keys(%servers)) { 1753: push(@{$by_hostname{$servers{$id}}},$id); 1754: } 1755: foreach my $hostname (sort(keys(%by_hostname))) { 1756: if (@{$by_hostname{$hostname}} > 1) { 1757: my $match = 0; 1758: foreach my $id (@{$by_hostname{$hostname}}) { 1759: if (&host_domain($id) eq $dom) { 1760: $uniqservers{$id} = $hostname; 1761: $match = 1; 1762: } 1763: } 1764: unless ($match) { 1765: $uniqservers{$by_hostname{$hostname}[0]} = $hostname; 1766: } 1767: } else { 1768: $uniqservers{$by_hostname{$hostname}[0]} = $hostname; 1769: } 1770: } 1771: return %uniqservers; 1772: } 1773: 1774: sub trusted_domains { 1775: my ($cmdtype,$calldom) = @_; 1776: my ($trusted,$untrusted); 1777: if (&domain($calldom) eq '') { 1778: return ($trusted,$untrusted); 1779: } 1780: unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) { 1781: return ($trusted,$untrusted); 1782: } 1783: my $callprimary = &domain($calldom,'primary'); 1784: my $intcalldom = &Apache::lonnet::internet_dom($callprimary); 1785: if ($intcalldom eq '') { 1786: return ($trusted,$untrusted); 1787: } 1788: 1789: my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom); 1790: unless (defined($cached)) { 1791: my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom); 1792: &Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600); 1793: $trustconfig = $domconfig{'trust'}; 1794: } 1795: if (ref($trustconfig)) { 1796: my (%possexc,%possinc,@allexc,@allinc); 1797: if (ref($trustconfig->{$cmdtype}) eq 'HASH') { 1798: if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') { 1799: map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; 1800: } 1801: if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') { 1802: $possinc{$intcalldom} = 1; 1803: map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}}; 1804: } 1805: } 1806: if (keys(%possexc)) { 1807: if (keys(%possinc)) { 1808: foreach my $key (sort(keys(%possexc))) { 1809: next if ($key eq $intcalldom); 1810: unless ($possinc{$key}) { 1811: push(@allexc,$key); 1812: } 1813: } 1814: } else { 1815: @allexc = sort(keys(%possexc)); 1816: } 1817: } 1818: if (keys(%possinc)) { 1819: $possinc{$intcalldom} = 1; 1820: @allinc = sort(keys(%possinc)); 1821: } 1822: if ((@allexc > 0) || (@allinc > 0)) { 1823: my %doms_by_intdom; 1824: my %allintdoms = &all_host_intdom(); 1825: my %alldoms = &all_host_domain(); 1826: foreach my $key (%allintdoms) { 1827: if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') { 1828: unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) { 1829: push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key}); 1830: } 1831: } else { 1832: $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}]; 1833: } 1834: } 1835: foreach my $exc (@allexc) { 1836: if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { 1837: push(@{$untrusted},@{$doms_by_intdom{$exc}}); 1838: } 1839: } 1840: foreach my $inc (@allinc) { 1841: if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { 1842: push(@{$trusted},@{$doms_by_intdom{$inc}}); 1843: } 1844: } 1845: } 1846: } 1847: return ($trusted,$untrusted); 1848: } 1849: 1850: sub will_trust { 1851: my ($cmdtype,$domain,$possdom) = @_; 1852: return 1 if ($domain eq $possdom); 1853: my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom); 1854: my $willtrust; 1855: if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) { 1856: if (grep(/^\Q$domain\E$/,@{$trustedref})) { 1857: $willtrust = 1; 1858: } 1859: } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) { 1860: unless (grep(/^\Q$domain\E$/,@{$untrustedref})) { 1861: $willtrust = 1; 1862: } 1863: } else { 1864: $willtrust = 1; 1865: } 1866: return $willtrust; 1867: } 1868: 1869: # ---------------------- Find the homebase for a user from domain's lib servers 1870: 1871: my %homecache; 1872: sub homeserver { 1873: my ($uname,$udom,$ignoreBadCache)=@_; 1874: my $index="$uname:$udom"; 1875: 1876: if (exists($homecache{$index})) { return $homecache{$index}; } 1877: 1878: my %servers = &get_servers($udom,'library'); 1879: foreach my $tryserver (keys(%servers)) { 1880: next if ($ignoreBadCache ne 'true' && 1881: exists($badServerCache{$tryserver})); 1882: 1883: my $answer=reply("home:$udom:$uname",$tryserver); 1884: if ($answer eq 'found') { 1885: delete($badServerCache{$tryserver}); 1886: return $homecache{$index}=$tryserver; 1887: } elsif ($answer eq 'no_host') { 1888: $badServerCache{$tryserver}=1; 1889: } 1890: } 1891: return 'no_host'; 1892: } 1893: 1894: # ----- Find the usernames behind a list of student/employee IDs or clicker IDs 1895: 1896: sub idget { 1897: my ($udom,$idsref,$namespace)=@_; 1898: my %returnhash=(); 1899: my @ids=(); 1900: if (ref($idsref) eq 'ARRAY') { 1901: @ids = @{$idsref}; 1902: } else { 1903: return %returnhash; 1904: } 1905: if ($namespace eq '') { 1906: $namespace = 'ids'; 1907: } 1908: 1909: my %servers = &get_servers($udom,'library'); 1910: foreach my $tryserver (keys(%servers)) { 1911: my $idlist=join('&', map { &escape($_); } @ids); 1912: if ($namespace eq 'ids') { 1913: $idlist=~tr/A-Z/a-z/; 1914: } 1915: my $reply; 1916: if ($namespace eq 'ids') { 1917: $reply=&reply("idget:$udom:".$idlist,$tryserver); 1918: } else { 1919: $reply=&reply("getdom:$udom:$namespace:$idlist",$tryserver); 1920: } 1921: my @answer=(); 1922: if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { 1923: @answer=split(/\&/,$reply); 1924: } ; 1925: my $i; 1926: for ($i=0;$i<=$#ids;$i++) { 1927: if ($answer[$i]) { 1928: $returnhash{$ids[$i]}=&unescape($answer[$i]); 1929: } 1930: } 1931: } 1932: return %returnhash; 1933: } 1934: 1935: # ------------------------------------- Find the IDs behind a list of usernames 1936: 1937: sub idrget { 1938: my ($udom,@unames)=@_; 1939: my %returnhash=(); 1940: foreach my $uname (@unames) { 1941: $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1]; 1942: } 1943: return %returnhash; 1944: } 1945: 1946: # Store away a list of names and associated student/employee IDs or clicker IDs 1947: 1948: sub idput { 1949: my ($udom,$idsref,$uhom,$namespace)=@_; 1950: my %servers=(); 1951: my %ids=(); 1952: my %byid = (); 1953: if (ref($idsref) eq 'HASH') { 1954: %ids=%{$idsref}; 1955: } 1956: if ($namespace eq '') { 1957: $namespace = 'ids'; 1958: } 1959: foreach my $uname (keys(%ids)) { 1960: &cput('environment',{'id'=>$ids{$uname}},$udom,$uname); 1961: if ($uhom eq '') { 1962: $uhom=&homeserver($uname,$udom); 1963: } 1964: if ($uhom ne 'no_host') { 1965: my $esc_unam=&escape($uname); 1966: if ($namespace eq 'ids') { 1967: my $id=&escape($ids{$uname}); 1968: $id=~tr/A-Z/a-z/; 1969: my $esc_unam=&escape($uname); 1970: $servers{$uhom}.=$id.'='.$esc_unam.'&'; 1971: } else { 1972: my @currids = split(/,/,$ids{$uname}); 1973: foreach my $id (@currids) { 1974: $byid{$uhom}{$id} .= $uname.','; 1975: } 1976: } 1977: } 1978: } 1979: if ($namespace eq 'clickers') { 1980: foreach my $server (keys(%byid)) { 1981: if (ref($byid{$server}) eq 'HASH') { 1982: foreach my $id (keys(%{$byid{$server}})) { 1983: $byid{$server} =~ s/,$//; 1984: $servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&'; 1985: } 1986: } 1987: } 1988: } 1989: foreach my $server (keys(%servers)) { 1990: $servers{$server} =~ s/\&$//; 1991: if ($namespace eq 'ids') { 1992: &critical('idput:'.$udom.':'.$servers{$server},$server); 1993: } else { 1994: &critical('updateclickers:'.$udom.':add:'.$servers{$server},$server); 1995: } 1996: } 1997: } 1998: 1999: # ------------- Delete unwanted student/employee IDs or clicker IDs from domain 2000: 2001: sub iddel { 2002: my ($udom,$idshashref,$uhome,$namespace)=@_; 2003: my %result=(); 2004: my %ids=(); 2005: my %byid = (); 2006: if (ref($idshashref) eq 'HASH') { 2007: %ids=%{$idshashref}; 2008: } else { 2009: return %result; 2010: } 2011: if ($namespace eq '') { 2012: $namespace = 'ids'; 2013: } 2014: my %servers=(); 2015: while (my ($id,$unamestr) = each(%ids)) { 2016: if ($namespace eq 'ids') { 2017: my $uhom = $uhome; 2018: if ($uhom eq '') { 2019: $uhom=&homeserver($unamestr,$udom); 2020: } 2021: if ($uhom ne 'no_host') { 2022: $servers{$uhom}.='&'.&escape($id); 2023: } 2024: } else { 2025: my @curritems = split(/,/,$ids{$id}); 2026: foreach my $uname (@curritems) { 2027: my $uhom = $uhome; 2028: if ($uhom eq '') { 2029: $uhom=&homeserver($uname,$udom); 2030: } 2031: if ($uhom ne 'no_host') { 2032: $byid{$uhom}{$id} .= $uname.','; 2033: } 2034: } 2035: } 2036: } 2037: if ($namespace eq 'clickers') { 2038: foreach my $server (keys(%byid)) { 2039: if (ref($byid{$server}) eq 'HASH') { 2040: foreach my $id (keys(%{$byid{$server}})) { 2041: $byid{$server}{$id} =~ s/,$//; 2042: $servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&'; 2043: } 2044: } 2045: } 2046: } 2047: foreach my $server (keys(%servers)) { 2048: $servers{$server} =~ s/\&$//; 2049: if ($namespace eq 'ids') { 2050: $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome); 2051: } elsif ($namespace eq 'clickers') { 2052: $result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server); 2053: } 2054: } 2055: return %result; 2056: } 2057: 2058: # ----- Update clicker ID-to-username look-ups in clickers.db on library server 2059: 2060: sub updateclickers { 2061: my ($udom,$action,$idshashref,$uhome,$critical) = @_; 2062: my %clickers; 2063: if (ref($idshashref) eq 'HASH') { 2064: %clickers=%{$idshashref}; 2065: } else { 2066: return; 2067: } 2068: my $items=''; 2069: foreach my $item (keys(%clickers)) { 2070: $items.=&escape($item).'='.&escape($clickers{$item}).'&'; 2071: } 2072: $items=~s/\&$//; 2073: my $request = "updateclickers:$udom:$action:$items"; 2074: if ($critical) { 2075: return &critical($request,$uhome); 2076: } else { 2077: return &reply($request,$uhome); 2078: } 2079: } 2080: 2081: # ------------------------------dump from db file owned by domainconfig user 2082: sub dump_dom { 2083: my ($namespace, $udom, $regexp) = @_; 2084: 2085: $udom ||= $env{'user.domain'}; 2086: 2087: return () unless $udom; 2088: 2089: return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp); 2090: } 2091: 2092: # ------------------------------------------ get items from domain db files 2093: 2094: sub get_dom { 2095: my ($namespace,$storearr,$udom,$uhome)=@_; 2096: return if ($udom eq 'public'); 2097: my $items=''; 2098: foreach my $item (@$storearr) { 2099: $items.=&escape($item).'&'; 2100: } 2101: $items=~s/\&$//; 2102: if (!$udom) { 2103: $udom=$env{'user.domain'}; 2104: return if ($udom eq 'public'); 2105: if (defined(&domain($udom,'primary'))) { 2106: $uhome=&domain($udom,'primary'); 2107: } else { 2108: undef($uhome); 2109: } 2110: } else { 2111: if (!$uhome) { 2112: if (defined(&domain($udom,'primary'))) { 2113: $uhome=&domain($udom,'primary'); 2114: } 2115: } 2116: } 2117: if ($udom && $uhome && ($uhome ne 'no_host')) { 2118: my $rep; 2119: if ($namespace =~ /^enc/) { 2120: $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); 2121: } else { 2122: $rep=&reply("getdom:$udom:$namespace:$items",$uhome); 2123: } 2124: my %returnhash; 2125: if ($rep eq '' || $rep =~ /^error: 2 /) { 2126: return %returnhash; 2127: } 2128: my @pairs=split(/\&/,$rep); 2129: if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { 2130: return @pairs; 2131: } 2132: my $i=0; 2133: foreach my $item (@$storearr) { 2134: $returnhash{$item}=&thaw_unescape($pairs[$i]); 2135: $i++; 2136: } 2137: return %returnhash; 2138: } else { 2139: &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)"); 2140: } 2141: } 2142: 2143: # -------------------------------------------- put items in domain db files 2144: 2145: sub put_dom { 2146: my ($namespace,$storehash,$udom,$uhome)=@_; 2147: if (!$udom) { 2148: $udom=$env{'user.domain'}; 2149: if (defined(&domain($udom,'primary'))) { 2150: $uhome=&domain($udom,'primary'); 2151: } else { 2152: undef($uhome); 2153: } 2154: } else { 2155: if (!$uhome) { 2156: if (defined(&domain($udom,'primary'))) { 2157: $uhome=&domain($udom,'primary'); 2158: } 2159: } 2160: } 2161: if ($udom && $uhome && ($uhome ne 'no_host')) { 2162: my $items=''; 2163: foreach my $item (keys(%$storehash)) { 2164: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; 2165: } 2166: $items=~s/\&$//; 2167: if ($namespace =~ /^enc/) { 2168: return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); 2169: } else { 2170: return &reply("putdom:$udom:$namespace:$items",$uhome); 2171: } 2172: } else { 2173: &logthis("put_dom failed - no homeserver and/or domain"); 2174: } 2175: } 2176: 2177: # --------------------- newput for items in db file owned by domainconfig user 2178: sub newput_dom { 2179: my ($namespace,$storehash,$udom) = @_; 2180: my $result; 2181: if (!$udom) { 2182: $udom=$env{'user.domain'}; 2183: } 2184: if ($udom) { 2185: my $uname = &get_domainconfiguser($udom); 2186: $result = &newput($namespace,$storehash,$udom,$uname); 2187: } 2188: return $result; 2189: } 2190: 2191: # --------------------- delete for items in db file owned by domainconfig user 2192: sub del_dom { 2193: my ($namespace,$storearr,$udom)=@_; 2194: if (ref($storearr) eq 'ARRAY') { 2195: if (!$udom) { 2196: $udom=$env{'user.domain'}; 2197: } 2198: if ($udom) { 2199: my $uname = &get_domainconfiguser($udom); 2200: return &del($namespace,$storearr,$udom,$uname); 2201: } 2202: } 2203: } 2204: 2205: # ----------------------------------construct domainconfig user for a domain 2206: sub get_domainconfiguser { 2207: my ($udom) = @_; 2208: return $udom.'-domainconfig'; 2209: } 2210: 2211: sub retrieve_inst_usertypes { 2212: my ($udom) = @_; 2213: my (%returnhash,@order); 2214: my %domdefs = &Apache::lonnet::get_domain_defaults($udom); 2215: if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 2216: (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { 2217: return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'}); 2218: } else { 2219: if (defined(&domain($udom,'primary'))) { 2220: my $uhome=&domain($udom,'primary'); 2221: my $rep=&reply("inst_usertypes:$udom",$uhome); 2222: if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { 2223: &logthis("retrieve_inst_usertypes failed - $rep returned from $uhome in domain: $udom"); 2224: return (\%returnhash,\@order); 2225: } 2226: my ($hashitems,$orderitems) = split(/:/,$rep); 2227: my @pairs=split(/\&/,$hashitems); 2228: foreach my $item (@pairs) { 2229: my ($key,$value)=split(/=/,$item,2); 2230: $key = &unescape($key); 2231: next if ($key =~ /^error: 2 /); 2232: $returnhash{$key}=&thaw_unescape($value); 2233: } 2234: my @esc_order = split(/\&/,$orderitems); 2235: foreach my $item (@esc_order) { 2236: push(@order,&unescape($item)); 2237: } 2238: } else { 2239: &logthis("retrieve_inst_usertypes failed - no primary domain server for $udom"); 2240: } 2241: return (\%returnhash,\@order); 2242: } 2243: } 2244: 2245: sub is_domainimage { 2246: my ($url) = @_; 2247: if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) { 2248: if (&domain($1) ne '') { 2249: return '1'; 2250: } 2251: } 2252: return; 2253: } 2254: 2255: sub inst_directory_query { 2256: my ($srch) = @_; 2257: my $udom = $srch->{'srchdomain'}; 2258: my %results; 2259: my $homeserver = &domain($udom,'primary'); 2260: my $outcome; 2261: if ($homeserver ne '') { 2262: unless ($homeserver eq $perlvar{'lonHostID'}) { 2263: if ($srch->{'srchby'} eq 'email') { 2264: my $lcrev = &get_server_loncaparev($udom,$homeserver); 2265: my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); 2266: if (($major eq '' && $minor eq '') || ($major < 2) || 2267: (($major == 2) && ($minor < 12))) { 2268: return; 2269: } 2270: } 2271: } 2272: my $queryid=&reply("querysend:instdirsearch:". 2273: &escape($srch->{'srchby'}).':'. 2274: &escape($srch->{'srchterm'}).':'. 2275: &escape($srch->{'srchtype'}),$homeserver); 2276: my $host=&hostname($homeserver); 2277: if ($queryid !~/^\Q$host\E\_/) { 2278: &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom); 2279: return; 2280: } 2281: my $response = &get_query_reply($queryid); 2282: my $maxtries = 5; 2283: my $tries = 1; 2284: while (($response=~/^timeout/) && ($tries < $maxtries)) { 2285: $response = &get_query_reply($queryid); 2286: $tries ++; 2287: } 2288: 2289: if (!&error($response) && $response ne 'refused') { 2290: if ($response eq 'unavailable') { 2291: $outcome = $response; 2292: } else { 2293: $outcome = 'ok'; 2294: my @matches = split(/\n/,$response); 2295: foreach my $match (@matches) { 2296: my ($key,$value) = split(/=/,$match); 2297: $results{&unescape($key).':'.$udom} = &thaw_unescape($value); 2298: } 2299: } 2300: } 2301: } 2302: return ($outcome,%results); 2303: } 2304: 2305: sub usersearch { 2306: my ($srch) = @_; 2307: my $dom = $srch->{'srchdomain'}; 2308: my %results; 2309: my %libserv = &all_library(); 2310: my $query = 'usersearch'; 2311: foreach my $tryserver (keys(%libserv)) { 2312: if (&host_domain($tryserver) eq $dom) { 2313: unless ($tryserver eq $perlvar{'lonHostID'}) { 2314: if ($srch->{'srchby'} eq 'email') { 2315: my $lcrev = &get_server_loncaparev($dom,$tryserver); 2316: my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); 2317: next if (($major eq '' && $minor eq '') || ($major < 2) || 2318: (($major == 2) && ($minor < 12))); 2319: } 2320: } 2321: my $host=&hostname($tryserver); 2322: my $queryid= 2323: &reply("querysend:".&escape($query).':'. 2324: &escape($srch->{'srchby'}).':'. 2325: &escape($srch->{'srchtype'}).':'. 2326: &escape($srch->{'srchterm'}),$tryserver); 2327: if ($queryid !~/^\Q$host\E\_/) { 2328: &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver); 2329: next; 2330: } 2331: my $reply = &get_query_reply($queryid); 2332: my $maxtries = 1; 2333: my $tries = 1; 2334: while (($reply=~/^timeout/) && ($tries < $maxtries)) { 2335: $reply = &get_query_reply($queryid); 2336: $tries ++; 2337: } 2338: if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { 2339: &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries); 2340: } else { 2341: my @matches; 2342: if ($reply =~ /\n/) { 2343: @matches = split(/\n/,$reply); 2344: } else { 2345: @matches = split(/\&/,$reply); 2346: } 2347: foreach my $match (@matches) { 2348: my ($uname,$udom,%userhash); 2349: foreach my $entry (split(/:/,$match)) { 2350: my ($key,$value) = 2351: map {&unescape($_);} split(/=/,$entry); 2352: $userhash{$key} = $value; 2353: if ($key eq 'username') { 2354: $uname = $value; 2355: } elsif ($key eq 'domain') { 2356: $udom = $value; 2357: } 2358: } 2359: $results{$uname.':'.$udom} = \%userhash; 2360: } 2361: } 2362: } 2363: } 2364: return %results; 2365: } 2366: 2367: sub get_instuser { 2368: my ($udom,$uname,$id) = @_; 2369: my $homeserver = &domain($udom,'primary'); 2370: my ($outcome,%results); 2371: if ($homeserver ne '') { 2372: my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'. 2373: &escape($id).':'.&escape($udom),$homeserver); 2374: my $host=&hostname($homeserver); 2375: if ($queryid !~/^\Q$host\E\_/) { 2376: &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); 2377: return; 2378: } 2379: my $response = &get_query_reply($queryid); 2380: my $maxtries = 5; 2381: my $tries = 1; 2382: while (($response=~/^timeout/) && ($tries < $maxtries)) { 2383: $response = &get_query_reply($queryid); 2384: $tries ++; 2385: } 2386: if (!&error($response) && $response ne 'refused') { 2387: if ($response eq 'unavailable') { 2388: $outcome = $response; 2389: } else { 2390: $outcome = 'ok'; 2391: my @matches = split(/\n/,$response); 2392: foreach my $match (@matches) { 2393: my ($key,$value) = split(/=/,$match); 2394: $results{&unescape($key)} = &thaw_unescape($value); 2395: } 2396: } 2397: } 2398: } 2399: my %userinfo; 2400: if (ref($results{$uname}) eq 'HASH') { 2401: %userinfo = %{$results{$uname}}; 2402: } 2403: return ($outcome,%userinfo); 2404: } 2405: 2406: sub get_multiple_instusers { 2407: my ($udom,$users,$caller) = @_; 2408: my ($outcome,$results); 2409: if (ref($users) eq 'HASH') { 2410: my $count = keys(%{$users}); 2411: my $requested = &freeze_escape($users); 2412: my $homeserver = &domain($udom,'primary'); 2413: if ($homeserver ne '') { 2414: my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver); 2415: my $host=&hostname($homeserver); 2416: if ($queryid !~/^\Q$host\E\_/) { 2417: &logthis('get_multiple_instusers invalid queryid: '.$queryid. 2418: ' for host: '.$homeserver.'in domain '.$udom); 2419: return ($outcome,$results); 2420: } 2421: my $response = &get_query_reply($queryid); 2422: my $maxtries = 5; 2423: if ($count > 100) { 2424: $maxtries = 1+int($count/20); 2425: } 2426: my $tries = 1; 2427: while (($response=~/^timeout/) && ($tries <= $maxtries)) { 2428: $response = &get_query_reply($queryid); 2429: $tries ++; 2430: } 2431: if ($response eq '') { 2432: $results = {}; 2433: foreach my $key (keys(%{$users})) { 2434: my ($uname,$id); 2435: if ($caller eq 'id') { 2436: $id = $key; 2437: } else { 2438: $uname = $key; 2439: } 2440: my ($resp,%info) = &get_instuser($udom,$uname,$id); 2441: $outcome = $resp; 2442: if ($resp eq 'ok') { 2443: %{$results} = (%{$results}, %info); 2444: } else { 2445: last; 2446: } 2447: } 2448: } elsif(!&error($response) && ($response ne 'refused')) { 2449: if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) { 2450: $outcome = $response; 2451: } else { 2452: ($outcome,my $userdata) = split(/=/,$response,2); 2453: if ($outcome eq 'ok') { 2454: $results = &thaw_unescape($userdata); 2455: } 2456: } 2457: } 2458: } 2459: } 2460: return ($outcome,$results); 2461: } 2462: 2463: sub inst_rulecheck { 2464: my ($udom,$uname,$id,$item,$rules) = @_; 2465: my %returnhash; 2466: if ($udom ne '') { 2467: if (ref($rules) eq 'ARRAY') { 2468: @{$rules} = map {&escape($_);} (@{$rules}); 2469: my $rulestr = join(':',@{$rules}); 2470: my $homeserver=&domain($udom,'primary'); 2471: if (($homeserver ne '') && ($homeserver ne 'no_host')) { 2472: my $response; 2473: if ($item eq 'username') { 2474: $response=&unescape(&reply('instrulecheck:'.&escape($udom). 2475: ':'.&escape($uname).':'.$rulestr, 2476: $homeserver)); 2477: } elsif ($item eq 'id') { 2478: $response=&unescape(&reply('instidrulecheck:'.&escape($udom). 2479: ':'.&escape($id).':'.$rulestr, 2480: $homeserver)); 2481: } elsif ($item eq 'selfcreate') { 2482: $response=&unescape(&reply('instselfcreatecheck:'. 2483: &escape($udom).':'.&escape($uname). 2484: ':'.$rulestr,$homeserver)); 2485: } 2486: if ($response ne 'refused') { 2487: my @pairs=split(/\&/,$response); 2488: foreach my $item (@pairs) { 2489: my ($key,$value)=split(/=/,$item,2); 2490: $key = &unescape($key); 2491: next if ($key =~ /^error: 2 /); 2492: $returnhash{$key}=&thaw_unescape($value); 2493: } 2494: } 2495: } 2496: } 2497: } 2498: return %returnhash; 2499: } 2500: 2501: sub inst_userrules { 2502: my ($udom,$check) = @_; 2503: my (%ruleshash,@ruleorder); 2504: if ($udom ne '') { 2505: my $homeserver=&domain($udom,'primary'); 2506: if (($homeserver ne '') && ($homeserver ne 'no_host')) { 2507: my $response; 2508: if ($check eq 'id') { 2509: $response=&reply('instidrules:'.&escape($udom), 2510: $homeserver); 2511: } elsif ($check eq 'email') { 2512: $response=&reply('instemailrules:'.&escape($udom), 2513: $homeserver); 2514: } else { 2515: $response=&reply('instuserrules:'.&escape($udom), 2516: $homeserver); 2517: } 2518: if (($response ne 'refused') && ($response ne 'error') && 2519: ($response ne 'unknown_cmd') && 2520: ($response ne 'no_such_host')) { 2521: my ($hashitems,$orderitems) = split(/:/,$response); 2522: my @pairs=split(/\&/,$hashitems); 2523: foreach my $item (@pairs) { 2524: my ($key,$value)=split(/=/,$item,2); 2525: $key = &unescape($key); 2526: next if ($key =~ /^error: 2 /); 2527: $ruleshash{$key}=&thaw_unescape($value); 2528: } 2529: my @esc_order = split(/\&/,$orderitems); 2530: foreach my $item (@esc_order) { 2531: push(@ruleorder,&unescape($item)); 2532: } 2533: } 2534: } 2535: } 2536: return (\%ruleshash,\@ruleorder); 2537: } 2538: 2539: # ------------- Get Authentication, Language and User Tools Defaults for Domain 2540: 2541: sub get_domain_defaults { 2542: my ($domain,$ignore_cache) = @_; 2543: return if (($domain eq '') || ($domain eq 'public')); 2544: my $cachetime = 60*60*24; 2545: unless ($ignore_cache) { 2546: my ($result,$cached)=&is_cached_new('domdefaults',$domain); 2547: if (defined($cached)) { 2548: if (ref($result) eq 'HASH') { 2549: return %{$result}; 2550: } 2551: } 2552: } 2553: my %domdefaults; 2554: my %domconfig = 2555: &Apache::lonnet::get_dom('configuration',['defaults','quotas', 2556: 'requestcourses','inststatus', 2557: 'coursedefaults','usersessions', 2558: 'requestauthor','selfenrollment', 2559: 'coursecategories','ssl','autoenroll', 2560: 'trust','helpsettings'],$domain); 2561: my @coursetypes = ('official','unofficial','community','textbook','placement'); 2562: if (ref($domconfig{'defaults'}) eq 'HASH') { 2563: $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 2564: $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; 2565: $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; 2566: $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; 2567: $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; 2568: $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; 2569: $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; 2570: $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; 2571: $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; 2572: } else { 2573: $domdefaults{'lang_def'} = &domain($domain,'lang_def'); 2574: $domdefaults{'auth_def'} = &domain($domain,'auth_def'); 2575: $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def'); 2576: } 2577: if (ref($domconfig{'quotas'}) eq 'HASH') { 2578: if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') { 2579: $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'}; 2580: } else { 2581: $domdefaults{'defaultquota'} = $domconfig{'quotas'}; 2582: } 2583: my @usertools = ('aboutme','blog','webdav','portfolio'); 2584: foreach my $item (@usertools) { 2585: if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { 2586: $domdefaults{$item} = $domconfig{'quotas'}{$item}; 2587: } 2588: } 2589: if (ref($domconfig{'quotas'}{'authorquota'}) eq 'HASH') { 2590: $domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'}; 2591: } 2592: } 2593: if (ref($domconfig{'requestcourses'}) eq 'HASH') { 2594: foreach my $item ('official','unofficial','community','textbook','placement') { 2595: $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; 2596: } 2597: } 2598: if (ref($domconfig{'requestauthor'}) eq 'HASH') { 2599: $domdefaults{'requestauthor'} = $domconfig{'requestauthor'}; 2600: } 2601: if (ref($domconfig{'inststatus'}) eq 'HASH') { 2602: foreach my $item ('inststatustypes','inststatusorder','inststatusguest') { 2603: $domdefaults{$item} = $domconfig{'inststatus'}{$item}; 2604: } 2605: } 2606: if (ref($domconfig{'coursedefaults'}) eq 'HASH') { 2607: $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'}; 2608: $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'}; 2609: $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'}; 2610: if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') { 2611: $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'}; 2612: } 2613: foreach my $type (@coursetypes) { 2614: if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') { 2615: unless ($type eq 'community') { 2616: $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type}; 2617: } 2618: } 2619: if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') { 2620: $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type}; 2621: } 2622: if ($domdefaults{'postsubmit'} eq 'on') { 2623: if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') { 2624: $domdefaults{$type.'postsubtimeout'} = 2625: $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; 2626: } 2627: } 2628: } 2629: if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') { 2630: if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') { 2631: my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}}; 2632: if (@clonecodes) { 2633: $domdefaults{'canclone'} = join('+',@clonecodes); 2634: } 2635: } 2636: } elsif ($domconfig{'coursedefaults'}{'canclone'}) { 2637: $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; 2638: } 2639: if ($domconfig{'coursedefaults'}{'texengine'}) { 2640: $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'}; 2641: } 2642: } 2643: if (ref($domconfig{'usersessions'}) eq 'HASH') { 2644: if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { 2645: $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'}; 2646: } 2647: if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') { 2648: $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; 2649: } 2650: if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') { 2651: $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'}; 2652: } 2653: } 2654: if (ref($domconfig{'selfenrollment'}) eq 'HASH') { 2655: if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') { 2656: my @settings = ('types','registered','enroll_dates','access_dates','section', 2657: 'approval','limit'); 2658: foreach my $type (@coursetypes) { 2659: if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') { 2660: my @mgrdc = (); 2661: foreach my $item (@settings) { 2662: if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') { 2663: push(@mgrdc,$item); 2664: } 2665: } 2666: if (@mgrdc) { 2667: $domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc); 2668: } 2669: } 2670: } 2671: } 2672: if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') { 2673: foreach my $type (@coursetypes) { 2674: if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') { 2675: foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) { 2676: $domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item}; 2677: } 2678: } 2679: } 2680: } 2681: } 2682: if (ref($domconfig{'coursecategories'}) eq 'HASH') { 2683: $domdefaults{'catauth'} = 'std'; 2684: $domdefaults{'catunauth'} = 'std'; 2685: if ($domconfig{'coursecategories'}{'auth'}) { 2686: $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'}; 2687: } 2688: if ($domconfig{'coursecategories'}{'unauth'}) { 2689: $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; 2690: } 2691: } 2692: if (ref($domconfig{'ssl'}) eq 'HASH') { 2693: if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { 2694: $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; 2695: } 2696: if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') { 2697: $domdefaults{'connect'} = $domconfig{'ssl'}{'connto'}; 2698: } 2699: if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') { 2700: $domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'}; 2701: } 2702: } 2703: if (ref($domconfig{'trust'}) eq 'HASH') { 2704: my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg); 2705: foreach my $prefix (@prefixes) { 2706: if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') { 2707: $domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix}; 2708: } 2709: } 2710: } 2711: if (ref($domconfig{'autoenroll'}) eq 'HASH') { 2712: $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; 2713: } 2714: if (ref($domconfig{'helpsettings'}) eq 'HASH') { 2715: $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'}; 2716: if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') { 2717: $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; 2718: } 2719: } 2720: &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); 2721: return %domdefaults; 2722: } 2723: 2724: sub get_dom_cats { 2725: my ($dom) = @_; 2726: return unless (&domain($dom)); 2727: my ($cats,$cached)=&is_cached_new('cats',$dom); 2728: unless (defined($cached)) { 2729: my %domconfig = &get_dom('configuration',['coursecategories'],$dom); 2730: if (ref($domconfig{'coursecategories'}) eq 'HASH') { 2731: if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') { 2732: %{$cats} = %{$domconfig{'coursecategories'}{'cats'}}; 2733: } else { 2734: $cats = {}; 2735: } 2736: } else { 2737: $cats = {}; 2738: } 2739: &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600); 2740: } 2741: return $cats; 2742: } 2743: 2744: sub get_dom_instcats { 2745: my ($dom) = @_; 2746: return unless (&domain($dom)); 2747: my ($instcats,$cached)=&is_cached_new('instcats',$dom); 2748: unless (defined($cached)) { 2749: my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order); 2750: my $totcodes = &retrieve_instcodes(\%coursecodes,$dom); 2751: if ($totcodes > 0) { 2752: my $caller = 'global'; 2753: if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes, 2754: \@codetitles,\%cat_titles,\%cat_order) eq 'ok') { 2755: $instcats = { 2756: codes => \%codes, 2757: codetitles => \@codetitles, 2758: cat_titles => \%cat_titles, 2759: cat_order => \%cat_order, 2760: }; 2761: &do_cache_new('instcats',$dom,$instcats,3600); 2762: } 2763: } 2764: } 2765: return $instcats; 2766: } 2767: 2768: sub retrieve_instcodes { 2769: my ($coursecodes,$dom) = @_; 2770: my $totcodes; 2771: my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course'); 2772: foreach my $course (keys(%courses)) { 2773: if (ref($courses{$course}) eq 'HASH') { 2774: if ($courses{$course}{'inst_code'} ne '') { 2775: $$coursecodes{$course} = $courses{$course}{'inst_code'}; 2776: $totcodes ++; 2777: } 2778: } 2779: } 2780: return $totcodes; 2781: } 2782: 2783: sub course_portal_url { 2784: my ($cnum,$cdom) = @_; 2785: my $chome = &homeserver($cnum,$cdom); 2786: my $hostname = &hostname($chome); 2787: my $protocol = $protocol{$chome}; 2788: $protocol = 'http' if ($protocol ne 'https'); 2789: my %domdefaults = &get_domain_defaults($cdom); 2790: my $firsturl; 2791: if ($domdefaults{'portal_def'}) { 2792: $firsturl = $domdefaults{'portal_def'}; 2793: } else { 2794: $firsturl = $protocol.'://'.$hostname; 2795: } 2796: return $firsturl; 2797: } 2798: 2799: # --------------------------------------------- Get domain config for passwords 2800: 2801: sub get_passwdconf { 2802: my ($dom) = @_; 2803: my (%passwdconf,$gotconf,$lookup); 2804: my ($result,$cached)=&is_cached_new('passwdconf',$dom); 2805: if (defined($cached)) { 2806: if (ref($result) eq 'HASH') { 2807: %passwdconf = %{$result}; 2808: $gotconf = 1; 2809: } 2810: } 2811: unless ($gotconf) { 2812: my %domconfig = &get_dom('configuration',['passwords'],$dom); 2813: if (ref($domconfig{'passwords'}) eq 'HASH') { 2814: %passwdconf = %{$domconfig{'passwords'}}; 2815: } 2816: my $cachetime = 24*60*60; 2817: &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime); 2818: } 2819: return %passwdconf; 2820: } 2821: 2822: # --------------------------------------------------- Assign a key to a student 2823: 2824: sub assign_access_key { 2825: # 2826: # a valid key looks like uname:udom#comments 2827: # comments are being appended 2828: # 2829: my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_; 2830: $kdom= 2831: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($kdom)); 2832: $knum= 2833: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($knum)); 2834: $cdom= 2835: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); 2836: $cnum= 2837: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); 2838: $udom=$env{'user.name'} unless (defined($udom)); 2839: $uname=$env{'user.domain'} unless (defined($uname)); 2840: my %existing=&get('accesskeys',[$ckey],$kdom,$knum); 2841: if (($existing{$ckey}=~/^\#(.*)$/) || # - new key 2842: ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) { 2843: # assigned to this person 2844: # - this should not happen, 2845: # unless something went wrong 2846: # the first time around 2847: # ready to assign 2848: $logentry=$1.'; '.$logentry; 2849: if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry}, 2850: $kdom,$knum) eq 'ok') { 2851: # key now belongs to user 2852: my $envkey='key.'.$cdom.'_'.$cnum; 2853: if (&put('environment',{$envkey => $ckey}) eq 'ok') { 2854: &appenv({'environment.'.$envkey => $ckey}); 2855: return 'ok'; 2856: } else { 2857: return 2858: 'error: Count not permanently assign key, will need to be re-entered later.'; 2859: } 2860: } else { 2861: return 'error: Could not assign key, try again later.'; 2862: } 2863: } elsif (!$existing{$ckey}) { 2864: # the key does not exist 2865: return 'error: The key does not exist'; 2866: } else { 2867: # the key is somebody else's 2868: return 'error: The key is already in use'; 2869: } 2870: } 2871: 2872: # ------------------------------------------ put an additional comment on a key 2873: 2874: sub comment_access_key { 2875: # 2876: # a valid key looks like uname:udom#comments 2877: # comments are being appended 2878: # 2879: my ($ckey,$cdom,$cnum,$logentry)=@_; 2880: $cdom= 2881: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); 2882: $cnum= 2883: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); 2884: my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); 2885: if ($existing{$ckey}) { 2886: $existing{$ckey}.='; '.$logentry; 2887: # ready to assign 2888: if (&put('accesskeys',{$ckey=>$existing{$ckey}}, 2889: $cdom,$cnum) eq 'ok') { 2890: return 'ok'; 2891: } else { 2892: return 'error: Count not store comment.'; 2893: } 2894: } else { 2895: # the key does not exist 2896: return 'error: The key does not exist'; 2897: } 2898: } 2899: 2900: # ------------------------------------------------------ Generate a set of keys 2901: 2902: sub generate_access_keys { 2903: my ($number,$cdom,$cnum,$logentry)=@_; 2904: $cdom= 2905: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); 2906: $cnum= 2907: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); 2908: unless (&allowed('mky',$cdom)) { return 0; } 2909: unless (($cdom) && ($cnum)) { return 0; } 2910: if ($number>10000) { return 0; } 2911: sleep(2); # make sure don't get same seed twice 2912: srand(time()^($$+($$<<15))); # from "Programming Perl" 2913: my $total=0; 2914: for (my $i=1;$i<=$number;$i++) { 2915: my $newkey=sprintf("%lx",int(100000*rand)).'-'. 2916: sprintf("%lx",int(100000*rand)).'-'. 2917: sprintf("%lx",int(100000*rand)); 2918: $newkey=~s/1/g/g; # folks mix up 1 and l 2919: $newkey=~s/0/h/g; # and also 0 and O 2920: my %existing=&get('accesskeys',[$newkey],$cdom,$cnum); 2921: if ($existing{$newkey}) { 2922: $i--; 2923: } else { 2924: if (&put('accesskeys', 2925: { $newkey => '# generated '.localtime(). 2926: ' by '.$env{'user.name'}.'@'.$env{'user.domain'}. 2927: '; '.$logentry }, 2928: $cdom,$cnum) eq 'ok') { 2929: $total++; 2930: } 2931: } 2932: } 2933: &log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, 2934: 'Generated '.$total.' keys for '.$cnum.' at '.$cdom); 2935: return $total; 2936: } 2937: 2938: # ------------------------------------------------------- Validate an accesskey 2939: 2940: sub validate_access_key { 2941: my ($ckey,$cdom,$cnum,$udom,$uname)=@_; 2942: $cdom= 2943: $env{'course.'.$env{'request.course.id'}.'.domain'} unless (defined($cdom)); 2944: $cnum= 2945: $env{'course.'.$env{'request.course.id'}.'.num'} unless (defined($cnum)); 2946: $udom=$env{'user.domain'} unless (defined($udom)); 2947: $uname=$env{'user.name'} unless (defined($uname)); 2948: my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); 2949: return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/); 2950: } 2951: 2952: # ------------------------------------- Find the section of student in a course 2953: sub devalidate_getsection_cache { 2954: my ($udom,$unam,$courseid)=@_; 2955: my $hashid="$udom:$unam:$courseid"; 2956: &devalidate_cache_new('getsection',$hashid); 2957: } 2958: 2959: sub courseid_to_courseurl { 2960: my ($courseid) = @_; 2961: #already url style courseid 2962: return $courseid if ($courseid =~ m{^/}); 2963: 2964: if (exists($env{'course.'.$courseid.'.num'})) { 2965: my $cnum = $env{'course.'.$courseid.'.num'}; 2966: my $cdom = $env{'course.'.$courseid.'.domain'}; 2967: return "/$cdom/$cnum"; 2968: } 2969: 2970: my %courseinfo=&Apache::lonnet::coursedescription($courseid); 2971: if (exists($courseinfo{'num'})) { 2972: return "/$courseinfo{'domain'}/$courseinfo{'num'}"; 2973: } 2974: 2975: return undef; 2976: } 2977: 2978: sub getsection { 2979: my ($udom,$unam,$courseid)=@_; 2980: my $cachetime=1800; 2981: 2982: my $hashid="$udom:$unam:$courseid"; 2983: my ($result,$cached)=&is_cached_new('getsection',$hashid); 2984: if (defined($cached)) { return $result; } 2985: 2986: my %Pending; 2987: my %Expired; 2988: # 2989: # Each role can either have not started yet (pending), be active, 2990: # or have expired. 2991: # 2992: # If there is an active role, we are done. 2993: # 2994: # If there is more than one role which has not started yet, 2995: # choose the one which will start sooner 2996: # If there is one role which has not started yet, return it. 2997: # 2998: # If there is more than one expired role, choose the one which ended last. 2999: # If there is a role which has expired, return it. 3000: # 3001: $courseid = &courseid_to_courseurl($courseid); 3002: my %roleshash = &dump('roles',$udom,$unam,$courseid); 3003: foreach my $key (keys(%roleshash)) { 3004: next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); 3005: my $section=$1; 3006: if ($key eq $courseid.'_st') { $section=''; } 3007: my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key})); 3008: my $now=time; 3009: if (defined($end) && $end && ($now > $end)) { 3010: $Expired{$end}=$section; 3011: next; 3012: } 3013: if (defined($start) && $start && ($now < $start)) { 3014: $Pending{$start}=$section; 3015: next; 3016: } 3017: return &do_cache_new('getsection',$hashid,$section,$cachetime); 3018: } 3019: # 3020: # Presumedly there will be few matching roles from the above 3021: # loop and the sorting time will be negligible. 3022: if (scalar(keys(%Pending))) { 3023: my ($time) = sort {$a <=> $b} keys(%Pending); 3024: return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime); 3025: } 3026: if (scalar(keys(%Expired))) { 3027: my @sorted = sort {$a <=> $b} keys(%Expired); 3028: my $time = pop(@sorted); 3029: return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime); 3030: } 3031: return &do_cache_new('getsection',$hashid,'-1',$cachetime); 3032: } 3033: 3034: sub save_cache { 3035: &purge_remembered(); 3036: #&Apache::loncommon::validate_page(); 3037: undef(%env); 3038: undef($env_loaded); 3039: } 3040: 3041: my $to_remember=-1; 3042: my %remembered; 3043: my %accessed; 3044: my $kicks=0; 3045: my $hits=0; 3046: sub make_key { 3047: my ($name,$id) = @_; 3048: if (length($id) > 65 3049: && length(&escape($id)) > 200) { 3050: $id=length($id).':'.&Digest::MD5::md5_hex($id); 3051: } 3052: return &escape($name.':'.$id); 3053: } 3054: 3055: sub devalidate_cache_new { 3056: my ($name,$id,$debug) = @_; 3057: if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } 3058: my $remembered_id=$name.':'.$id; 3059: $id=&make_key($name,$id); 3060: $memcache->delete($id); 3061: delete($remembered{$remembered_id}); 3062: delete($accessed{$remembered_id}); 3063: } 3064: 3065: sub is_cached_new { 3066: my ($name,$id,$debug) = @_; 3067: my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) whenever possible 3068: if (exists($remembered{$remembered_id})) { 3069: if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); } 3070: $accessed{$remembered_id}=[&gettimeofday()]; 3071: $hits++; 3072: return ($remembered{$remembered_id},1); 3073: } 3074: $id=&make_key($name,$id); 3075: my $value = $memcache->get($id); 3076: if (!(defined($value))) { 3077: if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } 3078: return (undef,undef); 3079: } 3080: if ($value eq '__undef__') { 3081: if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } 3082: $value=undef; 3083: } 3084: &make_room($remembered_id,$value,$debug); 3085: if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } 3086: return ($value,1); 3087: } 3088: 3089: sub do_cache_new { 3090: my ($name,$id,$value,$time,$debug) = @_; 3091: my $remembered_id=$name.':'.$id; 3092: $id=&make_key($name,$id); 3093: my $setvalue=$value; 3094: if (!defined($setvalue)) { 3095: $setvalue='__undef__'; 3096: } 3097: if (!defined($time) ) { 3098: $time=600; 3099: } 3100: if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } 3101: my $result = $memcache->set($id,$setvalue,$time); 3102: if (! $result) { 3103: &logthis("caching of id -> $id failed"); 3104: $memcache->disconnect_all(); 3105: } 3106: # need to make a copy of $value 3107: &make_room($remembered_id,$value,$debug); 3108: return $value; 3109: } 3110: 3111: sub make_room { 3112: my ($remembered_id,$value,$debug)=@_; 3113: 3114: $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value) 3115: : $value; 3116: if ($to_remember<0) { return; } 3117: $accessed{$remembered_id}=[&gettimeofday()]; 3118: if (scalar(keys(%remembered)) <= $to_remember) { return; } 3119: my $to_kick; 3120: my $max_time=0; 3121: foreach my $other (keys(%accessed)) { 3122: if (&tv_interval($accessed{$other}) > $max_time) { 3123: $to_kick=$other; 3124: $max_time=&tv_interval($accessed{$other}); 3125: } 3126: } 3127: delete($remembered{$to_kick}); 3128: delete($accessed{$to_kick}); 3129: $kicks++; 3130: if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); } 3131: return; 3132: } 3133: 3134: sub purge_remembered { 3135: #&logthis("Tossing ".scalar(keys(%remembered))); 3136: #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); 3137: undef(%remembered); 3138: undef(%accessed); 3139: } 3140: # ------------------------------------- Read an entry from a user's environment 3141: 3142: sub userenvironment { 3143: my ($udom,$unam,@what)=@_; 3144: my $items; 3145: foreach my $item (@what) { 3146: $items.=&escape($item).'&'; 3147: } 3148: $items=~s/\&$//; 3149: my %returnhash=(); 3150: my $uhome = &homeserver($unam,$udom); 3151: unless ($uhome eq 'no_host') { 3152: my @answer=split(/\&/, 3153: &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome)); 3154: if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) { 3155: return %returnhash; 3156: } 3157: my $i; 3158: for ($i=0;$i<=$#what;$i++) { 3159: $returnhash{$what[$i]}=&unescape($answer[$i]); 3160: } 3161: } 3162: return %returnhash; 3163: } 3164: 3165: # ---------------------------------------------------------- Get a studentphoto 3166: sub studentphoto { 3167: my ($udom,$unam,$ext) = @_; 3168: my $home=&Apache::lonnet::homeserver($unam,$udom); 3169: if (defined($env{'request.course.id'})) { 3170: if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) { 3171: if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) { 3172: return(&retrievestudentphoto($udom,$unam,$ext)); 3173: } else { 3174: my ($result,$perm_reqd)= 3175: &Apache::lonnet::auto_photo_permission($unam,$udom); 3176: if ($result eq 'ok') { 3177: if (!($perm_reqd eq 'yes')) { 3178: return(&retrievestudentphoto($udom,$unam,$ext)); 3179: } 3180: } 3181: } 3182: } 3183: } else { 3184: my ($result,$perm_reqd) = 3185: &Apache::lonnet::auto_photo_permission($unam,$udom); 3186: if ($result eq 'ok') { 3187: if (!($perm_reqd eq 'yes')) { 3188: return(&retrievestudentphoto($udom,$unam,$ext)); 3189: } 3190: } 3191: } 3192: return '/adm/lonKaputt/lonlogo_broken.gif'; 3193: } 3194: 3195: sub retrievestudentphoto { 3196: my ($udom,$unam,$ext,$type) = @_; 3197: my $home=&Apache::lonnet::homeserver($unam,$udom); 3198: my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home); 3199: if ($ret eq 'ok') { 3200: my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext"; 3201: if ($type eq 'thumbnail') { 3202: $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 3203: } 3204: my $tokenurl=&Apache::lonnet::tokenwrapper($url); 3205: return $tokenurl; 3206: } else { 3207: if ($type eq 'thumbnail') { 3208: return '/adm/lonKaputt/genericstudent_tn.gif'; 3209: } else { 3210: return '/adm/lonKaputt/lonlogo_broken.gif'; 3211: } 3212: } 3213: } 3214: 3215: # -------------------------------------------------------------------- New chat 3216: 3217: sub chatsend { 3218: my ($newentry,$anon,$group)=@_; 3219: my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'}; 3220: my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'}; 3221: my $chome=$env{'course.'.$env{'request.course.id'}.'.home'}; 3222: &reply('chatsend:'.$cdom.':'.$cnum.':'. 3223: &escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'. 3224: &escape($newentry)).':'.$group,$chome); 3225: } 3226: 3227: # ------------------------------------------ Find current version of a resource 3228: 3229: sub getversion { 3230: my $fname=&clutter(shift); 3231: unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; } 3232: return &currentversion(&filelocation('',$fname)); 3233: } 3234: 3235: sub currentversion { 3236: my $fname=shift; 3237: my $author=$fname; 3238: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 3239: my ($udom,$uname)=split(/\//,$author); 3240: my $home=&homeserver($uname,$udom); 3241: if ($home eq 'no_host') { 3242: return -1; 3243: } 3244: my $answer=&reply("currentversion:$fname",$home); 3245: if (($answer eq 'con_lost') || ($answer eq 'rejected')) { 3246: return -1; 3247: } 3248: return $answer; 3249: } 3250: 3251: # 3252: # Return special version number of resource if set by override, empty otherwise 3253: # 3254: sub usedversion { 3255: my $fname=shift; 3256: unless ($fname) { $fname=$env{'request.uri'}; } 3257: my ($urlversion)=($fname=~/\.(\d+)\.\w+$/); 3258: if ($urlversion) { return $urlversion; } 3259: return ''; 3260: } 3261: 3262: # ----------------------------- Subscribe to a resource, return URL if possible 3263: 3264: sub subscribe { 3265: my $fname=shift; 3266: if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } 3267: $fname=~s/[\n\r]//g; 3268: my $author=$fname; 3269: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 3270: my ($udom,$uname)=split(/\//,$author); 3271: my $home=homeserver($uname,$udom); 3272: if ($home eq 'no_host') { 3273: return 'not_found'; 3274: } 3275: my $answer=reply("sub:$fname",$home); 3276: if (($answer eq 'con_lost') || ($answer eq 'rejected')) { 3277: $answer.=' by '.$home; 3278: } 3279: return $answer; 3280: } 3281: 3282: # -------------------------------------------------------------- Replicate file 3283: 3284: sub repcopy { 3285: my $filename=shift; 3286: $filename=~s/\/+/\//g; 3287: my $londocroot = $perlvar{'lonDocRoot'}; 3288: if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; } 3289: if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; } 3290: if ($filename=~m{^\Q$londocroot/userfiles/\E} or 3291: $filename=~m{^/*(uploaded|editupload)/}) { 3292: return &repcopy_userfile($filename); 3293: } 3294: $filename=~s/[\n\r]//g; 3295: my $transname="$filename.in.transfer"; 3296: # FIXME: this should flock 3297: if ((-e $filename) || (-e $transname)) { return 'ok'; } 3298: my $remoteurl=subscribe($filename); 3299: if ($remoteurl =~ /^con_lost by/) { 3300: &logthis("Subscribe returned $remoteurl: $filename"); 3301: return 'unavailable'; 3302: } elsif ($remoteurl eq 'not_found') { 3303: #&logthis("Subscribe returned not_found: $filename"); 3304: return 'not_found'; 3305: } elsif ($remoteurl =~ /^rejected by/) { 3306: &logthis("Subscribe returned $remoteurl: $filename"); 3307: return 'forbidden'; 3308: } elsif ($remoteurl eq 'directory') { 3309: return 'ok'; 3310: } else { 3311: my $author=$filename; 3312: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 3313: my ($udom,$uname)=split(/\//,$author); 3314: my $home=homeserver($uname,$udom); 3315: unless ($home eq $perlvar{'lonHostID'}) { 3316: my @parts=split(/\//,$filename); 3317: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; 3318: if ($path ne "$londocroot/res") { 3319: &logthis("Malconfiguration for replication: $filename"); 3320: return 'bad_request'; 3321: } 3322: my $count; 3323: for ($count=5;$count<$#parts;$count++) { 3324: $path.="/$parts[$count]"; 3325: if ((-e $path)!=1) { 3326: mkdir($path,0777); 3327: } 3328: } 3329: my $request=new HTTP::Request('GET',"$remoteurl"); 3330: my $response; 3331: if ($remoteurl =~ m{/raw/}) { 3332: $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1); 3333: } else { 3334: $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1); 3335: } 3336: if ($response->is_error()) { 3337: unlink($transname); 3338: my $message=$response->status_line; 3339: &logthis("WARNING:" 3340: ." LWP get: $message: $filename"); 3341: return 'unavailable'; 3342: } else { 3343: if ($remoteurl!~/\.meta$/) { 3344: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); 3345: my $mresponse; 3346: if ($remoteurl =~ m{/raw/}) { 3347: $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1); 3348: } else { 3349: $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1); 3350: } 3351: if ($mresponse->is_error()) { 3352: unlink($filename.'.meta'); 3353: &logthis( 3354: "INFO: No metadata: $filename"); 3355: } 3356: } 3357: rename($transname,$filename); 3358: return 'ok'; 3359: } 3360: } 3361: } 3362: } 3363: 3364: # ------------------------------------------------ Get server side include body 3365: sub ssi_body { 3366: my ($filelink,%form)=@_; 3367: if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { 3368: $form{'LONCAPA_INTERNAL_no_discussion'}='true'; 3369: } 3370: my $output=''; 3371: my $response; 3372: if ($filelink=~/^https?\:/) { 3373: ($output,$response)=&externalssi($filelink); 3374: } else { 3375: $filelink .= $filelink=~/\?/ ? '&' : '?'; 3376: $filelink .= 'inhibitmenu=yes'; 3377: ($output,$response)=&ssi($filelink,%form); 3378: } 3379: $output=~s|//(\s*)?\s||gs; 3380: $output=~s/^.*?\<body[^\>]*\>//si; 3381: $output=~s/\<\/body\s*\>.*?$//si; 3382: if (wantarray) { 3383: return ($output, $response); 3384: } else { 3385: return $output; 3386: } 3387: } 3388: 3389: # --------------------------------------------------------- Server Side Include 3390: 3391: sub absolute_url { 3392: my ($host_name) = @_; 3393: my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); 3394: if ($host_name eq '') { 3395: $host_name = $ENV{'SERVER_NAME'}; 3396: } 3397: return $protocol.$host_name; 3398: } 3399: 3400: # 3401: # Server side include. 3402: # Parameters: 3403: # fn Possibly encrypted resource name/id. 3404: # form Hash that describes how the rendering should be done 3405: # and other things. 3406: # Returns: 3407: # Scalar context: The content of the response. 3408: # Array context: 2 element list of the content and the full response object. 3409: # 3410: sub ssi { 3411: 3412: my ($fn,%form)=@_; 3413: my $request; 3414: 3415: $form{'no_update_last_known'}=1; 3416: &Apache::lonenc::check_encrypt(\$fn); 3417: if (%form) { 3418: $request=new HTTP::Request('POST',&absolute_url().$fn); 3419: $request->content(join('&',map { 3420: my $name = escape($_); 3421: "$name=" . ( ref($form{$_}) eq 'ARRAY' 3422: ? join("&$name=", map {escape($_) } @{$form{$_}}) 3423: : &escape($form{$_}) ); 3424: } keys(%form))); 3425: } else { 3426: $request=new HTTP::Request('GET',&absolute_url().$fn); 3427: } 3428: 3429: $request->header(Cookie => $ENV{'HTTP_COOKIE'}); 3430: my $lonhost = $perlvar{'lonHostID'}; 3431: my $islocal; 3432: if (($env{'request.course.id'}) && 3433: ($form{'grade_courseid'} eq $env{'request.course.id'}) && 3434: ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') && 3435: ($form{'grade_symb'} ne '') && 3436: (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}. 3437: ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { 3438: $islocal = 1; 3439: } 3440: my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, 3441: '','','',$islocal); 3442: 3443: if (wantarray) { 3444: return ($response->content, $response); 3445: } else { 3446: return $response->content; 3447: } 3448: } 3449: 3450: sub externalssi { 3451: my ($url)=@_; 3452: my $request=new HTTP::Request('GET',$url); 3453: my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar); 3454: if (wantarray) { 3455: return ($response->content, $response); 3456: } else { 3457: return $response->content; 3458: } 3459: } 3460: 3461: 3462: # If the local copy of a replicated resource is outdated, trigger a 3463: # connection from the homeserver to flush the delayed queue. If no update 3464: # happens, remove local copies of outdated resource (and corresponding 3465: # metadata file). 3466: 3467: sub remove_stale_resfile { 3468: my ($url) = @_; 3469: my $removed; 3470: if ($url=~m{^/res/($match_domain)/($match_username)/}) { 3471: my $audom = $1; 3472: my $auname = $2; 3473: unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) { 3474: my $homeserver = &homeserver($auname,$audom); 3475: unless (($homeserver eq 'no_host') || 3476: (grep { $_ eq $homeserver } &current_machine_ids())) { 3477: my $fname = &filelocation('',$url); 3478: if (-e $fname) { 3479: my $hostname = &hostname($homeserver); 3480: if ($hostname) { 3481: my $protocol = $protocol{$homeserver}; 3482: $protocol = 'http' if ($protocol ne 'https'); 3483: my $uri = &declutter($url); 3484: my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri); 3485: my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1); 3486: if ($response->is_success()) { 3487: my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') ); 3488: my $locmodtime = (stat($fname))[9]; 3489: if ($locmodtime < $remmodtime) { 3490: my $stale; 3491: my $answer = &reply('pong',$homeserver); 3492: if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) { 3493: sleep(0.2); 3494: $locmodtime = (stat($fname))[9]; 3495: if ($locmodtime < $remmodtime) { 3496: my $posstransfer = $fname.'.in.transfer'; 3497: if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) { 3498: $removed = 1; 3499: } else { 3500: $stale = 1; 3501: } 3502: } else { 3503: $removed = 1; 3504: } 3505: } else { 3506: $stale = 1; 3507: } 3508: if ($stale) { 3509: unlink($fname); 3510: if ($uri!~/\.meta$/) { 3511: unlink($fname.'.meta'); 3512: } 3513: &reply("unsub:$fname",$homeserver); 3514: $removed = 1; 3515: } 3516: } 3517: } 3518: } 3519: } 3520: } 3521: } 3522: } 3523: return $removed; 3524: } 3525: 3526: # -------------------------------- Allow a /uploaded/ URI to be vouched for 3527: 3528: sub allowuploaded { 3529: my ($srcurl,$url)=@_; 3530: $url=&clutter(&declutter($url)); 3531: my $dir=$url; 3532: $dir=~s/\/[^\/]+$//; 3533: my %httpref=(); 3534: my $httpurl=&hreflocation('',$url); 3535: $httpref{'httpref.'.$httpurl}=$srcurl; 3536: &Apache::lonnet::appenv(\%httpref); 3537: } 3538: 3539: # 3540: # Determine if the current user should be able to edit a particular resource, 3541: # when viewing in course context. 3542: # (a) When viewing resource used to determine if "Edit" item is included in 3543: # Functions. 3544: # (b) When displaying folder contents in course editor, used to determine if 3545: # "Edit" link will be displayed alongside resource. 3546: # 3547: # input: six args -- filename (decluttered), course number, course domain, 3548: # url, symb (if registered) and group (if this is a group 3549: # item -- e.g., bulletin board, group page etc.). 3550: # output: array of five scalars -- 3551: # $cfile -- url for file editing if editable on current server 3552: # $home -- homeserver of resource (i.e., for author if published, 3553: # or course if uploaded.). 3554: # $switchserver -- 1 if server switch will be needed. 3555: # $forceedit -- 1 if icon/link should be to go to edit mode 3556: # $forceview -- 1 if icon/link should be to go to view mode 3557: # 3558: 3559: sub can_edit_resource { 3560: my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_; 3561: my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse); 3562: # 3563: # For aboutme pages user can only edit his/her own. 3564: # 3565: if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) { 3566: my ($sdom,$sname) = ($1,$2); 3567: if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) { 3568: $home = $env{'user.home'}; 3569: $cfile = $resurl; 3570: if ($env{'form.forceedit'}) { 3571: $forceview = 1; 3572: } else { 3573: $forceedit = 1; 3574: } 3575: return ($cfile,$home,$switchserver,$forceedit,$forceview); 3576: } else { 3577: return; 3578: } 3579: } 3580: 3581: if ($env{'request.course.id'}) { 3582: my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'}); 3583: if ($group ne '') { 3584: # if this is a group homepage or group bulletin board, check group privs 3585: my $allowed = 0; 3586: if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) { 3587: if ((&allowed('mdg',$env{'request.course.id'}. 3588: ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) || 3589: (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) { 3590: $allowed = 1; 3591: } 3592: } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) { 3593: if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) || 3594: (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) { 3595: $allowed = 1; 3596: } 3597: } 3598: if ($allowed) { 3599: $home=&homeserver($cnum,$cdom); 3600: if ($env{'form.forceedit'}) { 3601: $forceview = 1; 3602: } else { 3603: $forceedit = 1; 3604: } 3605: $cfile = $resurl; 3606: } else { 3607: return; 3608: } 3609: } else { 3610: if ($resurl =~ m{^/?adm/viewclasslist$}) { 3611: unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) { 3612: return; 3613: } 3614: } elsif (!$crsedit) { 3615: # 3616: # No edit allowed where CC has switched to student role. 3617: # 3618: return; 3619: } 3620: } 3621: } 3622: 3623: if ($file ne '') { 3624: if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) { 3625: if (&is_course_upload($file,$cnum,$cdom)) { 3626: $uploaded = 1; 3627: $incourse = 1; 3628: if ($file =~/\.(htm|html|css|js|txt)$/) { 3629: $cfile = &hreflocation('',$file); 3630: if ($env{'form.forceedit'}) { 3631: $forceview = 1; 3632: } else { 3633: $forceedit = 1; 3634: } 3635: } 3636: } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) { 3637: $incourse = 1; 3638: if ($env{'form.forceedit'}) { 3639: $forceview = 1; 3640: } else { 3641: $forceedit = 1; 3642: } 3643: $cfile = $resurl; 3644: } elsif (($resurl ne '') && (&is_on_map($resurl))) { 3645: if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) { 3646: $incourse = 1; 3647: if ($env{'form.forceedit'}) { 3648: $forceview = 1; 3649: } else { 3650: $forceedit = 1; 3651: } 3652: $cfile = $resurl; 3653: } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') { 3654: $incourse = 1; 3655: $cfile = $resurl.'/smpedit'; 3656: } elsif ($resurl =~ m{^/adm/wrapper/ext/}) { 3657: $incourse = 1; 3658: if ($env{'form.forceedit'}) { 3659: $forceview = 1; 3660: } else { 3661: $forceedit = 1; 3662: } 3663: $cfile = $resurl; 3664: } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) { 3665: my ($map,$id,$res) = &decode_symb($symb); 3666: if ($map =~ /\.page$/) { 3667: $incourse = 1; 3668: if ($env{'form.forceedit'}) { 3669: $forceview = 1; 3670: $cfile = $map; 3671: } else { 3672: $forceedit = 1; 3673: $cfile = '/adm/wrapper'.$resurl; 3674: } 3675: } 3676: } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { 3677: $incourse = 1; 3678: if ($env{'form.forceedit'}) { 3679: $forceview = 1; 3680: } else { 3681: $forceedit = 1; 3682: } 3683: $cfile = $resurl; 3684: } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { 3685: $incourse = 1; 3686: if ($env{'form.forceedit'}) { 3687: $forceview = 1; 3688: } else { 3689: $forceedit = 1; 3690: } 3691: $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl"); 3692: } 3693: } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') { 3694: my $template = '/res/lib/templates/simpleproblem.problem'; 3695: if (&is_on_map($template)) { 3696: $incourse = 1; 3697: $forceview = 1; 3698: $cfile = $template; 3699: } 3700: } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) { 3701: $incourse = 1; 3702: if ($env{'form.forceedit'}) { 3703: $forceview = 1; 3704: } else { 3705: $forceedit = 1; 3706: } 3707: $cfile = $resurl; 3708: } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { 3709: $incourse = 1; 3710: if ($env{'form.forceedit'}) { 3711: $forceview = 1; 3712: } else { 3713: $forceedit = 1; 3714: } 3715: $cfile = $resurl; 3716: } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { 3717: $incourse = 1; 3718: $forceview = 1; 3719: if ($symb) { 3720: my ($map,$id,$res)=&decode_symb($symb); 3721: $env{'request.symb'} = $symb; 3722: $cfile = &clutter($res); 3723: } else { 3724: $cfile = $env{'form.suppurl'}; 3725: my $escfile = &unescape($cfile); 3726: if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { 3727: $cfile = '/adm/wrapper'.$escfile; 3728: } else { 3729: $escfile =~ s{^http://}{}; 3730: $cfile = &escape("/adm/wrapper/ext/$escfile"); 3731: } 3732: } 3733: } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { 3734: if ($env{'form.forceedit'}) { 3735: $forceview = 1; 3736: } else { 3737: $forceedit = 1; 3738: } 3739: $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl"); 3740: } 3741: } 3742: if ($uploaded || $incourse) { 3743: $home=&homeserver($cnum,$cdom); 3744: } elsif ($file !~ m{/$}) { 3745: $file=~s{^(priv/$match_domain/$match_username)}{/$1}; 3746: $file=~s{^($match_domain/$match_username)}{/priv/$1}; 3747: # Check that the user has permission to edit this resource 3748: my $setpriv = 1; 3749: my ($cfuname,$cfudom)=&constructaccess($file,$setpriv); 3750: if (defined($cfudom)) { 3751: $home=&homeserver($cfuname,$cfudom); 3752: $cfile=$file; 3753: } 3754: } 3755: if (($cfile ne '') && (!$incourse || $uploaded) && 3756: (($home ne '') && ($home ne 'no_host'))) { 3757: my @ids=&current_machine_ids(); 3758: unless (grep(/^\Q$home\E$/,@ids)) { 3759: $switchserver=1; 3760: } 3761: } 3762: } 3763: return ($cfile,$home,$switchserver,$forceedit,$forceview); 3764: } 3765: 3766: sub is_course_upload { 3767: my ($file,$cnum,$cdom) = @_; 3768: my $uploadpath = &LONCAPA::propath($cdom,$cnum); 3769: $uploadpath =~ s{^\/}{}; 3770: if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) || 3771: ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) { 3772: return 1; 3773: } 3774: return; 3775: } 3776: 3777: sub in_course { 3778: my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_; 3779: if ($hideprivileged) { 3780: my $skipuser; 3781: my %coursehash = &coursedescription($cdom.'_'.$cnum); 3782: my @possdoms = ($cdom); 3783: if ($coursehash{'checkforpriv'}) { 3784: push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); 3785: } 3786: if (&privileged($uname,$udom,\@possdoms)) { 3787: $skipuser = 1; 3788: if ($coursehash{'nothideprivileged'}) { 3789: foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { 3790: my $user; 3791: if ($item =~ /:/) { 3792: $user = $item; 3793: } else { 3794: $user = join(':',split(/[\@]/,$item)); 3795: } 3796: if ($user eq $uname.':'.$udom) { 3797: undef($skipuser); 3798: last; 3799: } 3800: } 3801: } 3802: if ($skipuser) { 3803: return 0; 3804: } 3805: } 3806: } 3807: $type ||= 'any'; 3808: if (!defined($cdom) || !defined($cnum)) { 3809: my $cid = $env{'request.course.id'}; 3810: $cdom = $env{'course.'.$cid.'.domain'}; 3811: $cnum = $env{'course.'.$cid.'.num'}; 3812: } 3813: my $typesref; 3814: if (($type eq 'any') || ($type eq 'all')) { 3815: $typesref = ['active','previous','future']; 3816: } elsif ($type eq 'previous' || $type eq 'future') { 3817: $typesref = [$type]; 3818: } 3819: my %roles = &get_my_roles($uname,$udom,'userroles', 3820: $typesref,undef,[$cdom]); 3821: my ($tmp) = keys(%roles); 3822: return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i); 3823: my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles)); 3824: if (@course_roles > 0) { 3825: return 1; 3826: } 3827: return 0; 3828: } 3829: 3830: # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course 3831: # input: action, courseID, current domain, intended 3832: # path to file, source of file, instruction to parse file for objects, 3833: # ref to hash for embedded objects, 3834: # ref to hash for codebase of java objects. 3835: # reference to scalar to accommodate mime type determined 3836: # from File::MMagic if $parser = parse. 3837: # 3838: # output: url to file (if action was uploaddoc), 3839: # ok if successful, or diagnostic message otherwise (if action was propagate or copy) 3840: # 3841: # Allows directory structure to be used within lonUsers/../userfiles/ for a 3842: # course. 3843: # 3844: # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file 3845: # will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in 3846: # course's home server. 3847: # 3848: # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will 3849: # be copied from $source (current location) to 3850: # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file 3851: # and will then be copied to 3852: # /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in 3853: # course's home server. 3854: # 3855: # action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file 3856: # will be retrived from $env{form.uploaddoc} (from DOCS interface) to 3857: # /home/httpd/html/userfiles/$domain/1/2/3/$course/$file 3858: # and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file 3859: # in course's home server. 3860: # 3861: 3862: sub process_coursefile { 3863: my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase, 3864: $mimetype)=@_; 3865: my $fetchresult; 3866: my $home=&homeserver($docuname,$docudom); 3867: if ($action eq 'propagate') { 3868: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, 3869: $home); 3870: } else { 3871: my $fpath = ''; 3872: my $fname = $file; 3873: ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); 3874: $fpath=$docudom.'/'.$docuname.'/'.$fpath; 3875: my $filepath = &build_filepath($fpath); 3876: if ($action eq 'copy') { 3877: if ($source eq '') { 3878: $fetchresult = 'no source file'; 3879: return $fetchresult; 3880: } else { 3881: my $destination = $filepath.'/'.$fname; 3882: rename($source,$destination); 3883: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, 3884: $home); 3885: } 3886: } elsif ($action eq 'uploaddoc') { 3887: open(my $fh,'>',$filepath.'/'.$fname); 3888: print $fh $env{'form.'.$source}; 3889: close($fh); 3890: if ($parser eq 'parse') { 3891: my $mm = new File::MMagic; 3892: my $type = $mm->checktype_filename($filepath.'/'.$fname); 3893: if ($type eq 'text/html') { 3894: my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); 3895: unless ($parse_result eq 'ok') { 3896: &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); 3897: } 3898: } 3899: if (ref($mimetype)) { 3900: $$mimetype = $type; 3901: } 3902: } 3903: $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, 3904: $home); 3905: if ($fetchresult eq 'ok') { 3906: return '/uploaded/'.$fpath.'/'.$fname; 3907: } else { 3908: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. 3909: ' to host '.$home.': '.$fetchresult); 3910: return '/adm/notfound.html'; 3911: } 3912: } 3913: } 3914: unless ( $fetchresult eq 'ok') { 3915: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. 3916: ' to host '.$home.': '.$fetchresult); 3917: } 3918: return $fetchresult; 3919: } 3920: 3921: sub build_filepath { 3922: my ($fpath) = @_; 3923: my $filepath=$perlvar{'lonDocRoot'}.'/userfiles'; 3924: unless ($fpath eq '') { 3925: my @parts=split('/',$fpath); 3926: foreach my $part (@parts) { 3927: $filepath.= '/'.$part; 3928: if ((-e $filepath)!=1) { 3929: mkdir($filepath,0777); 3930: } 3931: } 3932: } 3933: return $filepath; 3934: } 3935: 3936: sub store_edited_file { 3937: my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_; 3938: my $file = $primary_url; 3939: $file =~ s#^/uploaded/$docudom/$docuname/##; 3940: my $fpath = ''; 3941: my $fname = $file; 3942: ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); 3943: $fpath=$docudom.'/'.$docuname.'/'.$fpath; 3944: my $filepath = &build_filepath($fpath); 3945: open(my $fh,'>',$filepath.'/'.$fname); 3946: print $fh $content; 3947: close($fh); 3948: my $home=&homeserver($docuname,$docudom); 3949: $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, 3950: $home); 3951: if ($$fetchresult eq 'ok') { 3952: return '/uploaded/'.$fpath.'/'.$fname; 3953: } else { 3954: &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file. 3955: ' to host '.$home.': '.$$fetchresult); 3956: return '/adm/notfound.html'; 3957: } 3958: } 3959: 3960: sub clean_filename { 3961: my ($fname,$args)=@_; 3962: # Replace Windows backslashes by forward slashes 3963: $fname=~s/\\/\//g; 3964: if (!$args->{'keep_path'}) { 3965: # Get rid of everything but the actual filename 3966: $fname=~s/^.*\/([^\/]+)$/$1/; 3967: } 3968: # Replace spaces by underscores 3969: $fname=~s/\s+/\_/g; 3970: # Transliterate non-ascii text to ascii 3971: my $lang = &Apache::lonlocal::current_language(); 3972: $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang); 3973: # Replace all other weird characters by nothing 3974: $fname=~s{[^/\w\.\-]}{}g; 3975: # Replace all .\d. sequences with _\d. so they no longer look like version 3976: # numbers 3977: $fname=~s/\.(\d+)(?=\.)/_$1/g; 3978: return $fname; 3979: } 3980: 3981: # This Function checks if an Image's dimensions exceed either $resizewidth (width) 3982: # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an 3983: # image with the same aspect ratio as the original, but with dimensions which do 3984: # not exceed $resizewidth and $resizeheight. 3985: 3986: sub resizeImage { 3987: my ($img_path,$resizewidth,$resizeheight) = @_; 3988: my $ima = Image::Magick->new; 3989: my $resized; 3990: if (-e $img_path) { 3991: $ima->Read($img_path); 3992: if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) { 3993: my $width = $ima->Get('width'); 3994: my $height = $ima->Get('height'); 3995: if ($width > $resizewidth) { 3996: my $factor = $width/$resizewidth; 3997: my $newheight = $height/$factor; 3998: $ima->Scale(width=>$resizewidth,height=>$newheight); 3999: $resized = 1; 4000: } 4001: } 4002: if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) { 4003: my $width = $ima->Get('width'); 4004: my $height = $ima->Get('height'); 4005: if ($height > $resizeheight) { 4006: my $factor = $height/$resizeheight; 4007: my $newwidth = $width/$factor; 4008: $ima->Scale(width=>$newwidth,height=>$resizeheight); 4009: $resized = 1; 4010: } 4011: } 4012: if ($resized) { 4013: $ima->Write($img_path); 4014: } 4015: } 4016: return; 4017: } 4018: 4019: # --------------- Take an uploaded file and put it into the userfiles directory 4020: # input: $formname - the contents of the file are in $env{"form.$formname"} 4021: # the desired filename is in $env{"form.$formname.filename"} 4022: # $context - possible values: coursedoc, existingfile, overwrite, 4023: # canceloverwrite, scantron or ''. 4024: # if 'coursedoc': upload to the current course 4025: # if 'existingfile': write file to tmp/overwrites directory 4026: # if 'canceloverwrite': delete file written to tmp/overwrites directory 4027: # $context is passed as argument to &finishuserfileupload 4028: # $subdir - directory in userfile to store the file into 4029: # $parser - instruction to parse file for objects ($parser = parse) or 4030: # if context is 'scantron', $parser is hashref of csv column mapping 4031: # (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3, 4032: # Section => 4, CODE => 5, FirstQuestion => 9 }). 4033: # $allfiles - reference to hash for embedded objects 4034: # $codebase - reference to hash for codebase of java objects 4035: # $desuname - username for permanent storage of uploaded file 4036: # $dsetudom - domain for permanaent storage of uploaded file 4037: # $thumbwidth - width (pixels) of thumbnail to make for uploaded image 4038: # $thumbheight - height (pixels) of thumbnail to make for uploaded image 4039: # $resizewidth - width (pixels) to which to resize uploaded image 4040: # $resizeheight - height (pixels) to which to resize uploaded image 4041: # $mimetype - reference to scalar to accommodate mime type determined 4042: # from File::MMagic. 4043: # 4044: # output: url of file in userspace, or error: <message> 4045: # or /adm/notfound.html if failure to upload occurse 4046: 4047: sub userfileupload { 4048: my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname, 4049: $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight,$mimetype)=@_; 4050: if (!defined($subdir)) { $subdir='unknown'; } 4051: my $fname=$env{'form.'.$formname.'.filename'}; 4052: $fname=&clean_filename($fname); 4053: # See if there is anything left 4054: unless ($fname) { return 'error: no uploaded file'; } 4055: # If filename now begins with a . prepend unix timestamp _ milliseconds 4056: if ($fname =~ /^\./) { 4057: my ($s,$usec) = &gettimeofday(); 4058: while (length($usec) < 6) { 4059: $usec = '0'.$usec; 4060: } 4061: $fname = $s.'_'.substr($usec,0,3).$fname; 4062: } 4063: # Files uploaded to help request form, or uploaded to "create course" page are handled differently 4064: if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) || 4065: (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) || 4066: ($context eq 'existingfile') || ($context eq 'canceloverwrite')) { 4067: my $now = time; 4068: my $filepath; 4069: if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { 4070: $filepath = 'tmp/helprequests/'.$now; 4071: } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { 4072: $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}. 4073: '_'.$env{'user.domain'}.'/pending'; 4074: } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { 4075: my ($docuname,$docudom); 4076: if ($destudom =~ /^$match_domain$/) { 4077: $docudom = $destudom; 4078: } else { 4079: $docudom = $env{'user.domain'}; 4080: } 4081: if ($destuname =~ /^$match_username$/) { 4082: $docuname = $destuname; 4083: } else { 4084: $docuname = $env{'user.name'}; 4085: } 4086: if (exists($env{'form.group'})) { 4087: $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; 4088: $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; 4089: } 4090: $filepath = 'tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$subdir; 4091: if ($context eq 'canceloverwrite') { 4092: my $tempfile = $perlvar{'lonDaemons'}.'/'.$filepath.'/'.$fname; 4093: if (-e $tempfile) { 4094: my @info = stat($tempfile); 4095: if ($info[9] eq $env{'form.timestamp'}) { 4096: unlink($tempfile); 4097: } 4098: } 4099: return; 4100: } 4101: } 4102: # Create the directory if not present 4103: my @parts=split(/\//,$filepath); 4104: my $fullpath = $perlvar{'lonDaemons'}; 4105: for (my $i=0;$i<@parts;$i++) { 4106: $fullpath .= '/'.$parts[$i]; 4107: if ((-e $fullpath)!=1) { 4108: mkdir($fullpath,0777); 4109: } 4110: } 4111: open(my $fh,'>',$fullpath.'/'.$fname); 4112: print $fh $env{'form.'.$formname}; 4113: close($fh); 4114: if ($context eq 'existingfile') { 4115: my @info = stat($fullpath.'/'.$fname); 4116: return ($fullpath.'/'.$fname,$info[9]); 4117: } else { 4118: return $fullpath.'/'.$fname; 4119: } 4120: } 4121: if ($subdir eq 'scantron') { 4122: $fname = 'scantron_orig_'.$fname; 4123: } else { 4124: $fname="$subdir/$fname"; 4125: } 4126: if ($context eq 'coursedoc') { 4127: my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; 4128: my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; 4129: if ($env{'form.folder'} =~ m/^(default|supplemental)/) { 4130: return &finishuserfileupload($docuname,$docudom, 4131: $formname,$fname,$parser,$allfiles, 4132: $codebase,$thumbwidth,$thumbheight, 4133: $resizewidth,$resizeheight,$context,$mimetype); 4134: } else { 4135: if ($env{'form.folder'}) { 4136: $fname=$env{'form.folder'}.'/'.$fname; 4137: } 4138: return &process_coursefile('uploaddoc',$docuname,$docudom, 4139: $fname,$formname,$parser, 4140: $allfiles,$codebase,$mimetype); 4141: } 4142: } elsif (defined($destuname)) { 4143: my $docuname=$destuname; 4144: my $docudom=$destudom; 4145: return &finishuserfileupload($docuname,$docudom,$formname,$fname, 4146: $parser,$allfiles,$codebase, 4147: $thumbwidth,$thumbheight, 4148: $resizewidth,$resizeheight,$context,$mimetype); 4149: } else { 4150: my $docuname=$env{'user.name'}; 4151: my $docudom=$env{'user.domain'}; 4152: if ((exists($env{'form.group'})) || ($context eq 'syllabus')) { 4153: $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; 4154: $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; 4155: } 4156: return &finishuserfileupload($docuname,$docudom,$formname,$fname, 4157: $parser,$allfiles,$codebase, 4158: $thumbwidth,$thumbheight, 4159: $resizewidth,$resizeheight,$context,$mimetype); 4160: } 4161: } 4162: 4163: sub finishuserfileupload { 4164: my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, 4165: $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context,$mimetype) = @_; 4166: my $path=$docudom.'/'.$docuname.'/'; 4167: my $filepath=$perlvar{'lonDocRoot'}; 4168: 4169: my ($fnamepath,$file,$fetchthumb); 4170: $file=$fname; 4171: if ($fname=~m|/|) { 4172: ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); 4173: $path.=$fnamepath.'/'; 4174: } 4175: my @parts=split(/\//,$filepath.'/userfiles/'.$path); 4176: my $count; 4177: for ($count=4;$count<=$#parts;$count++) { 4178: $filepath.="/$parts[$count]"; 4179: if ((-e $filepath)!=1) { 4180: mkdir($filepath,0777); 4181: } 4182: } 4183: 4184: # Save the file 4185: { 4186: if (!open(FH,'>',$filepath.'/'.$file)) { 4187: &logthis('Failed to create '.$filepath.'/'.$file); 4188: print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); 4189: return '/adm/notfound.html'; 4190: } 4191: if ($context eq 'overwrite') { 4192: my $source = LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname; 4193: my $target = $filepath.'/'.$file; 4194: if (-e $source) { 4195: my @info = stat($source); 4196: if ($info[9] eq $env{'form.timestamp'}) { 4197: unless (&File::Copy::move($source,$target)) { 4198: &logthis('Failed to overwrite '.$filepath.'/'.$file); 4199: return "Moving from $source failed"; 4200: } 4201: } else { 4202: return "Temporary file: $source had unexpected date/time for last modification"; 4203: } 4204: } else { 4205: return "Temporary file: $source missing"; 4206: } 4207: } elsif (!print FH ($env{'form.'.$formname})) { 4208: &logthis('Failed to write to '.$filepath.'/'.$file); 4209: print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); 4210: return '/adm/notfound.html'; 4211: } 4212: close(FH); 4213: if ($resizewidth && $resizeheight) { 4214: my $mm = new File::MMagic; 4215: my $mime_type = $mm->checktype_filename($filepath.'/'.$file); 4216: if ($mime_type =~ m{^image/}) { 4217: &resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight); 4218: } 4219: } 4220: } 4221: if (($context eq 'coursedoc') || ($parser eq 'parse')) { 4222: if (ref($mimetype)) { 4223: if ($$mimetype eq '') { 4224: my $mm = new File::MMagic; 4225: my $type = $mm->checktype_filename($filepath.'/'.$file); 4226: $$mimetype = $type; 4227: } 4228: } 4229: } 4230: if (($context ne 'scantron') && ($parser eq 'parse')) { 4231: if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { 4232: my $parse_result = &extract_embedded_items($filepath.'/'.$file, 4233: $allfiles,$codebase); 4234: unless ($parse_result eq 'ok') { 4235: &logthis('Failed to parse '.$filepath.$file. 4236: ' for embedded media: '.$parse_result); 4237: } 4238: } 4239: } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) { 4240: my $format = $env{'form.scantron_format'}; 4241: &bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format); 4242: } 4243: if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { 4244: my $input = $filepath.'/'.$file; 4245: my $output = $filepath.'/'.'tn-'.$file; 4246: my $thumbsize = $thumbwidth.'x'.$thumbheight; 4247: my @args = ('convert','-sample',$thumbsize,$input,$output); 4248: system({$args[0]} @args); 4249: if (-e $filepath.'/'.'tn-'.$file) { 4250: $fetchthumb = 1; 4251: } 4252: } 4253: 4254: # Notify homeserver to grep it 4255: # 4256: my $docuhome=&homeserver($docuname,$docudom); 4257: my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); 4258: if ($fetchresult eq 'ok') { 4259: if ($fetchthumb) { 4260: my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome); 4261: if ($thumbresult ne 'ok') { 4262: &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '. 4263: $docuhome.': '.$thumbresult); 4264: } 4265: } 4266: # 4267: # Return the URL to it 4268: return '/uploaded/'.$path.$file; 4269: } else { 4270: &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. 4271: ': '.$fetchresult); 4272: return '/adm/notfound.html'; 4273: } 4274: } 4275: 4276: sub extract_embedded_items { 4277: my ($fullpath,$allfiles,$codebase,$content) = @_; 4278: my @state = (); 4279: my (%lastids,%related,%shockwave,%flashvars); 4280: my %javafiles = ( 4281: codebase => '', 4282: code => '', 4283: archive => '' 4284: ); 4285: my %mediafiles = ( 4286: src => '', 4287: movie => '', 4288: ); 4289: my $p; 4290: if ($content) { 4291: $p = HTML::LCParser->new($content); 4292: } else { 4293: $p = HTML::LCParser->new($fullpath); 4294: } 4295: while (my $t=$p->get_token()) { 4296: if ($t->[0] eq 'S') { 4297: my ($tagname, $attr) = ($t->[1],$t->[2]); 4298: push(@state, $tagname); 4299: if (lc($tagname) eq 'allow') { 4300: &add_filetype($allfiles,$attr->{'src'},'src'); 4301: } 4302: if (lc($tagname) eq 'img') { 4303: &add_filetype($allfiles,$attr->{'src'},'src'); 4304: } 4305: if (lc($tagname) eq 'a') { 4306: unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) { 4307: &add_filetype($allfiles,$attr->{'href'},'href'); 4308: } 4309: } 4310: if (lc($tagname) eq 'script') { 4311: my $src; 4312: if ($attr->{'archive'} =~ /\.jar$/i) { 4313: &add_filetype($allfiles,$attr->{'archive'},'archive'); 4314: } else { 4315: if ($attr->{'src'} ne '') { 4316: $src = $attr->{'src'}; 4317: &add_filetype($allfiles,$src,'src'); 4318: } 4319: } 4320: my $text = $p->get_trimmed_text(); 4321: if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) { 4322: my @swfargs = split(/,/,$1); 4323: foreach my $item (@swfargs) { 4324: $item =~ s/["']//g; 4325: $item =~ s/^\s+//; 4326: $item =~ s/\s+$//; 4327: } 4328: if (($swfargs[0] ne'') && ($swfargs[2] ne '')) { 4329: if (ref($related{$swfargs[0]}) eq 'ARRAY') { 4330: push(@{$related{$swfargs[0]}},$swfargs[2]); 4331: } else { 4332: $related{$swfargs[0]} = [$swfargs[2]]; 4333: } 4334: } 4335: } 4336: } 4337: if (lc($tagname) eq 'link') { 4338: if (lc($attr->{'rel'}) eq 'stylesheet') { 4339: &add_filetype($allfiles,$attr->{'href'},'href'); 4340: } 4341: } 4342: if (lc($tagname) eq 'object' || 4343: (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) { 4344: foreach my $item (keys(%javafiles)) { 4345: $javafiles{$item} = ''; 4346: } 4347: if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) { 4348: $lastids{lc($tagname)} = $attr->{'id'}; 4349: } 4350: } 4351: if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') { 4352: my $name = lc($attr->{'name'}); 4353: foreach my $item (keys(%javafiles)) { 4354: if ($name eq $item) { 4355: $javafiles{$item} = $attr->{'value'}; 4356: last; 4357: } 4358: } 4359: my $pathfrom; 4360: foreach my $item (keys(%mediafiles)) { 4361: if ($name eq $item) { 4362: $pathfrom = $attr->{'value'}; 4363: $shockwave{$lastids{lc($state[-2])}} = $pathfrom; 4364: &add_filetype($allfiles,$pathfrom,$name); 4365: last; 4366: } 4367: } 4368: if ($name eq 'flashvars') { 4369: $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'}; 4370: } 4371: if ($pathfrom ne '') { 4372: &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])}, 4373: $pathfrom); 4374: } 4375: } 4376: if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') { 4377: foreach my $item (keys(%javafiles)) { 4378: if ($attr->{$item}) { 4379: $javafiles{$item} = $attr->{$item}; 4380: last; 4381: } 4382: } 4383: foreach my $item (keys(%mediafiles)) { 4384: if ($attr->{$item}) { 4385: &add_filetype($allfiles,$attr->{$item},$item); 4386: last; 4387: } 4388: } 4389: if (lc($tagname) eq 'embed') { 4390: if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) { 4391: &embedded_dependency($allfiles,\%related,$attr->{'name'}, 4392: $attr->{'src'}); 4393: } 4394: } 4395: } 4396: if (lc($tagname) eq 'iframe') { 4397: my $src = $attr->{'src'} ; 4398: if (($src ne '') && ($src !~ m{^(/|https?://)})) { 4399: &add_filetype($allfiles,$src,'src'); 4400: } elsif ($src =~ m{^/}) { 4401: if ($env{'request.course.id'}) { 4402: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 4403: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; 4404: my $url = &hreflocation('',$fullpath); 4405: if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) { 4406: my $relpath = $1; 4407: if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) { 4408: &add_filetype($allfiles,$1,'src'); 4409: } 4410: } 4411: } 4412: } 4413: } 4414: if ($t->[4] =~ m{/>$}) { 4415: pop(@state); 4416: } 4417: } elsif ($t->[0] eq 'E') { 4418: my ($tagname) = ($t->[1]); 4419: if ($javafiles{'codebase'} ne '') { 4420: $javafiles{'codebase'} .= '/'; 4421: } 4422: if (lc($tagname) eq 'applet' || 4423: lc($tagname) eq 'object' || 4424: (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object') 4425: ) { 4426: foreach my $item (keys(%javafiles)) { 4427: if ($item ne 'codebase' && $javafiles{$item} ne '') { 4428: my $file=$javafiles{'codebase'}.$javafiles{$item}; 4429: &add_filetype($allfiles,$file,$item); 4430: } 4431: } 4432: } 4433: pop @state; 4434: } 4435: } 4436: foreach my $id (sort(keys(%flashvars))) { 4437: if ($shockwave{$id} ne '') { 4438: my @pairs = split(/\&/,$flashvars{$id}); 4439: foreach my $pair (@pairs) { 4440: my ($key,$value) = split(/\=/,$pair); 4441: if ($key eq 'thumb') { 4442: &add_filetype($allfiles,$value,$key); 4443: } elsif ($key eq 'content') { 4444: my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$}); 4445: my ($ext) = ($value =~ /\.([^.]+)$/); 4446: if ($ext ne '') { 4447: &add_filetype($allfiles,$path.$value,$ext); 4448: } 4449: } 4450: } 4451: } 4452: } 4453: return 'ok'; 4454: } 4455: 4456: sub add_filetype { 4457: my ($allfiles,$file,$type)=@_; 4458: if (exists($allfiles->{$file})) { 4459: unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) { 4460: push(@{$allfiles->{$file}}, &escape($type)); 4461: } 4462: } else { 4463: @{$allfiles->{$file}} = (&escape($type)); 4464: } 4465: } 4466: 4467: sub embedded_dependency { 4468: my ($allfiles,$related,$identifier,$pathfrom) = @_; 4469: if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) { 4470: if (($identifier ne '') && 4471: (ref($related->{$identifier}) eq 'ARRAY') && 4472: ($pathfrom ne '')) { 4473: my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$}); 4474: foreach my $dep (@{$related->{$identifier}}) { 4475: &add_filetype($allfiles,$path.$dep,'object'); 4476: } 4477: } 4478: } 4479: return; 4480: } 4481: 4482: sub bubblesheet_converter { 4483: my ($cdom,$fullpath,$config,$format) = @_; 4484: if ((&domain($cdom) ne '') && 4485: ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) && 4486: (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) { 4487: my (%csvcols,%csvoptions); 4488: if (ref($config->{'fields'}) eq 'HASH') { 4489: %csvcols = %{$config->{'fields'}}; 4490: } 4491: if (ref($config->{'options'}) eq 'HASH') { 4492: %csvoptions = %{$config->{'options'}}; 4493: } 4494: my %csvbynum = reverse(%csvcols); 4495: my %scantronconf = &get_scantron_config($format,$cdom); 4496: if (keys(%scantronconf)) { 4497: my %bynum = ( 4498: $scantronconf{CODEstart} => 'CODEstart', 4499: $scantronconf{IDstart} => 'IDstart', 4500: $scantronconf{PaperID} => 'PaperID', 4501: $scantronconf{FirstName} => 'FirstName', 4502: $scantronconf{LastName} => 'LastName', 4503: $scantronconf{Qstart} => 'Qstart', 4504: ); 4505: my @ordered; 4506: foreach my $item (sort { $a <=> $b } keys(%bynum)) { 4507: push(@ordered,$bynum{$item}); 4508: } 4509: my %mapstart = ( 4510: CODEstart => 'CODE', 4511: IDstart => 'ID', 4512: PaperID => 'PaperID', 4513: FirstName => 'FirstName', 4514: LastName => 'LastName', 4515: Qstart => 'FirstQuestion', 4516: ); 4517: my %maplength = ( 4518: CODEstart => 'CODElength', 4519: IDstart => 'IDlength', 4520: PaperID => 'PaperIDlength', 4521: FirstName => 'FirstNamelength', 4522: LastName => 'LastNamelength', 4523: ); 4524: if (open(my $fh,'<',$fullpath)) { 4525: my $output; 4526: my %lettdig = &letter_to_digits(); 4527: my %diglett = reverse(%lettdig); 4528: my $numletts = scalar(keys(%lettdig)); 4529: my $num = 0; 4530: while (my $line=<$fh>) { 4531: $num ++; 4532: next if (($num == 1) && ($csvoptions{'hdr'} == 1)); 4533: $line =~ s{[\r\n]+$}{}; 4534: my %found; 4535: my @values = split(/,/,$line); 4536: my ($qstart,$record); 4537: for (my $i=0; $i<@values; $i++) { 4538: if ((($qstart ne '') && ($i > $qstart)) || 4539: ($csvbynum{$i} eq 'FirstQuestion')) { 4540: if ($values[$i] eq '') { 4541: $values[$i] = $scantronconf{'Qoff'}; 4542: } elsif ($scantronconf{'Qon'} eq 'number') { 4543: if ($values[$i] =~ /^[A-Ja-j]$/) { 4544: $values[$i] = $lettdig{uc($values[$i])}; 4545: } 4546: } elsif ($scantronconf{'Qon'} eq 'letter') { 4547: if ($values[$i] =~ /^[0-9]$/) { 4548: $values[$i] = $diglett{$values[$i]}; 4549: } 4550: } else { 4551: if ($values[$i] =~ /^[0-9A-Ja-j]$/) { 4552: my $digit; 4553: if ($values[$i] =~ /^[A-Ja-j]$/) { 4554: $digit = $lettdig{uc($values[$i])}-1; 4555: if ($values[$i] eq 'J') { 4556: $digit += $numletts; 4557: } 4558: } elsif ($values[$i] =~ /^[0-9]$/) { 4559: $digit = $values[$i]-1; 4560: if ($values[$i] eq '0') { 4561: $digit += $numletts; 4562: } 4563: } 4564: my $qval=''; 4565: for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) { 4566: if ($j == $digit) { 4567: $qval .= $scantronconf{'Qon'}; 4568: } else { 4569: $qval .= $scantronconf{'Qoff'}; 4570: } 4571: } 4572: $values[$i] = $qval; 4573: } 4574: } 4575: if (length($values[$i]) > $scantronconf{'Qlength'}) { 4576: $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'}); 4577: } 4578: my $numblank = $scantronconf{'Qlength'} - length($values[$i]); 4579: if ($numblank > 0) { 4580: $values[$i] .= ($scantronconf{'Qoff'} x $numblank); 4581: } 4582: if ($csvbynum{$i} eq 'FirstQuestion') { 4583: $qstart = $i; 4584: $found{$csvbynum{$i}} = $values[$i]; 4585: } else { 4586: $found{'FirstQuestion'} .= $values[$i]; 4587: } 4588: } elsif (exists($csvbynum{$i})) { 4589: if ($csvoptions{'rem'}) { 4590: $values[$i] =~ s/^\s+//; 4591: } 4592: if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) { 4593: while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) { 4594: $values[$i] = '0'.$values[$i]; 4595: } 4596: } 4597: $found{$csvbynum{$i}} = $values[$i]; 4598: } 4599: } 4600: foreach my $item (@ordered) { 4601: my $currlength = 1+length($record); 4602: my $numspaces = $scantronconf{$item} - $currlength; 4603: if ($numspaces > 0) { 4604: $record .= (' ' x $numspaces); 4605: } 4606: if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) { 4607: unless ($item eq 'Qstart') { 4608: if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) { 4609: $found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}}); 4610: } 4611: } 4612: $record .= $found{$mapstart{$item}}; 4613: } 4614: } 4615: $output .= "$record\n"; 4616: } 4617: close($fh); 4618: if ($output) { 4619: if (open(my $fh,'>',$fullpath)) { 4620: print $fh $output; 4621: close($fh); 4622: } 4623: } 4624: } 4625: } 4626: return; 4627: } 4628: } 4629: 4630: sub letter_to_digits { 4631: my %lettdig = ( 4632: A => 1, 4633: B => 2, 4634: C => 3, 4635: D => 4, 4636: E => 5, 4637: F => 6, 4638: G => 7, 4639: H => 8, 4640: I => 9, 4641: J => 0, 4642: ); 4643: return %lettdig; 4644: } 4645: 4646: sub get_scantron_config { 4647: my ($which,$cdom) = @_; 4648: my @lines = &get_scantronformat_file($cdom); 4649: my %config; 4650: #FIXME probably should move to XML it has already gotten a bit much now 4651: foreach my $line (@lines) { 4652: my ($name,$descrip)=split(/:/,$line); 4653: if ($name ne $which ) { next; } 4654: chomp($line); 4655: my @config=split(/:/,$line); 4656: $config{'name'}=$config[0]; 4657: $config{'description'}=$config[1]; 4658: $config{'CODElocation'}=$config[2]; 4659: $config{'CODEstart'}=$config[3]; 4660: $config{'CODElength'}=$config[4]; 4661: $config{'IDstart'}=$config[5]; 4662: $config{'IDlength'}=$config[6]; 4663: $config{'Qstart'}=$config[7]; 4664: $config{'Qlength'}=$config[8]; 4665: $config{'Qoff'}=$config[9]; 4666: $config{'Qon'}=$config[10]; 4667: $config{'PaperID'}=$config[11]; 4668: $config{'PaperIDlength'}=$config[12]; 4669: $config{'FirstName'}=$config[13]; 4670: $config{'FirstNamelength'}=$config[14]; 4671: $config{'LastName'}=$config[15]; 4672: $config{'LastNamelength'}=$config[16]; 4673: $config{'BubblesPerRow'}=$config[17]; 4674: last; 4675: } 4676: return %config; 4677: } 4678: 4679: sub get_scantronformat_file { 4680: my ($cdom) = @_; 4681: if ($cdom eq '') { 4682: $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'}; 4683: } 4684: my %domconfig = &get_dom('configuration',['scantron'],$cdom); 4685: my $gottab = 0; 4686: my @lines; 4687: if (ref($domconfig{'scantron'}) eq 'HASH') { 4688: if ($domconfig{'scantron'}{'scantronformat'} ne '') { 4689: my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'}); 4690: if ($formatfile ne '-1') { 4691: @lines = split("\n",$formatfile,-1); 4692: $gottab = 1; 4693: } 4694: } 4695: } 4696: if (!$gottab) { 4697: my $confname = $cdom.'-domainconfig'; 4698: my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab'; 4699: my $formatfile = &getfile($default); 4700: if ($formatfile ne '-1') { 4701: @lines = split("\n",$formatfile,-1); 4702: $gottab = 1; 4703: } 4704: } 4705: if (!$gottab) { 4706: my @domains = &current_machine_domains(); 4707: if (grep(/^\Q$cdom\E$/,@domains)) { 4708: if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) { 4709: @lines = <$fh>; 4710: close($fh); 4711: } 4712: } else { 4713: if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) { 4714: @lines = <$fh>; 4715: close($fh); 4716: } 4717: } 4718: } 4719: return @lines; 4720: } 4721: 4722: sub removeuploadedurl { 4723: my ($url)=@_; 4724: my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); 4725: return &removeuserfile($uname,$udom,$fname); 4726: } 4727: 4728: sub removeuserfile { 4729: my ($docuname,$docudom,$fname)=@_; 4730: my $home=&homeserver($docuname,$docudom); 4731: my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); 4732: if ($result eq 'ok') { 4733: if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { 4734: my $metafile = $fname.'.meta'; 4735: my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 4736: my $url = "/uploaded/$docudom/$docuname/$fname"; 4737: my ($file,$group) = (&parse_portfolio_url($url))[3,4]; 4738: my $sqlresult = 4739: &update_portfolio_table($docuname,$docudom,$file, 4740: 'portfolio_metadata',$group, 4741: 'delete'); 4742: } 4743: } 4744: return $result; 4745: } 4746: 4747: sub mkdiruserfile { 4748: my ($docuname,$docudom,$dir)=@_; 4749: my $home=&homeserver($docuname,$docudom); 4750: return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home); 4751: } 4752: 4753: sub renameuserfile { 4754: my ($docuname,$docudom,$old,$new)=@_; 4755: my $home=&homeserver($docuname,$docudom); 4756: my $result = &reply("renameuserfile:$docudom:$docuname:". 4757: &escape("$old").':'.&escape("$new"),$home); 4758: if ($result eq 'ok') { 4759: if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) { 4760: my $oldmeta = $old.'.meta'; 4761: my $newmeta = $new.'.meta'; 4762: my $metaresult = 4763: &renameuserfile($docuname,$docudom,$oldmeta,$newmeta); 4764: my $url = "/uploaded/$docudom/$docuname/$old"; 4765: my ($file,$group) = (&parse_portfolio_url($url))[3,4]; 4766: my $sqlresult = 4767: &update_portfolio_table($docuname,$docudom,$file, 4768: 'portfolio_metadata',$group, 4769: 'delete'); 4770: } 4771: } 4772: return $result; 4773: } 4774: 4775: # ------------------------------------------------------------------------- Log 4776: 4777: sub log { 4778: my ($dom,$nam,$hom,$what)=@_; 4779: return critical("log:$dom:$nam:$what",$hom); 4780: } 4781: 4782: # ------------------------------------------------------------------ Course Log 4783: # 4784: # This routine flushes several buffers of non-mission-critical nature 4785: # 4786: 4787: sub flushcourselogs { 4788: &logthis('Flushing log buffers'); 4789: # 4790: # course logs 4791: # This is a log of all transactions in a course, which can be used 4792: # for data mining purposes 4793: # 4794: # It also collects the courseid database, which lists last transaction 4795: # times and course titles for all courseids 4796: # 4797: my %courseidbuffer=(); 4798: foreach my $crsid (keys(%courselogs)) { 4799: if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. 4800: &escape($courselogs{$crsid}), 4801: $coursehombuf{$crsid}) eq 'ok') { 4802: delete $courselogs{$crsid}; 4803: } else { 4804: &logthis('Failed to flush log buffer for '.$crsid); 4805: if (length($courselogs{$crsid})>40000) { 4806: &logthis("WARNING: Buffer for ".$crsid. 4807: " exceeded maximum size, deleting."); 4808: delete $courselogs{$crsid}; 4809: } 4810: } 4811: $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = { 4812: 'description' => $coursedescrbuf{$crsid}, 4813: 'inst_code' => $courseinstcodebuf{$crsid}, 4814: 'type' => $coursetypebuf{$crsid}, 4815: 'owner' => $courseownerbuf{$crsid}, 4816: }; 4817: } 4818: # 4819: # Write course id database (reverse lookup) to homeserver of courses 4820: # Is used in pickcourse 4821: # 4822: foreach my $crs_home (keys(%courseidbuffer)) { 4823: my $response = &courseidput(&host_domain($crs_home), 4824: $courseidbuffer{$crs_home}, 4825: $crs_home,'timeonly'); 4826: } 4827: # 4828: # File accesses 4829: # Writes to the dynamic metadata of resources to get hit counts, etc. 4830: # 4831: foreach my $entry (keys(%accesshash)) { 4832: if ($entry =~ /___count$/) { 4833: my ($dom,$name); 4834: ($dom,$name,undef)= 4835: ($entry=~m{___($match_domain)/($match_name)/(.*)___count$}); 4836: if (! defined($dom) || $dom eq '' || 4837: ! defined($name) || $name eq '') { 4838: my $cid = $env{'request.course.id'}; 4839: $dom = $env{'request.'.$cid.'.domain'}; 4840: $name = $env{'request.'.$cid.'.num'}; 4841: } 4842: my $value = $accesshash{$entry}; 4843: my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/); 4844: my %temphash=($url => $value); 4845: my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); 4846: if ($result eq 'ok') { 4847: delete $accesshash{$entry}; 4848: } 4849: } else { 4850: my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); 4851: if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; } 4852: my %temphash=($entry => $accesshash{$entry}); 4853: if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { 4854: delete $accesshash{$entry}; 4855: } 4856: } 4857: } 4858: # 4859: # Roles 4860: # Reverse lookup of user roles for course faculty/staff and co-authorship 4861: # 4862: foreach my $entry (keys(%userrolehash)) { 4863: my ($role,$uname,$udom,$runame,$rudom,$rsec)= 4864: split(/\:/,$entry); 4865: if (&Apache::lonnet::put('nohist_userroles', 4866: { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} }, 4867: $rudom,$runame) eq 'ok') { 4868: delete $userrolehash{$entry}; 4869: } 4870: } 4871: # 4872: # Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au) 4873: # 4874: my %domrolebuffer = (); 4875: foreach my $entry (keys(%domainrolehash)) { 4876: my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); 4877: if ($domrolebuffer{$rudom}) { 4878: $domrolebuffer{$rudom}.='&'.&escape($entry). 4879: '='.&escape($domainrolehash{$entry}); 4880: } else { 4881: $domrolebuffer{$rudom}.=&escape($entry). 4882: '='.&escape($domainrolehash{$entry}); 4883: } 4884: delete $domainrolehash{$entry}; 4885: } 4886: foreach my $dom (keys(%domrolebuffer)) { 4887: my %servers; 4888: if (defined(&domain($dom,'primary'))) { 4889: my $primary=&domain($dom,'primary'); 4890: my $hostname=&hostname($primary); 4891: $servers{$primary} = $hostname; 4892: } else { 4893: %servers = &get_servers($dom,'library'); 4894: } 4895: foreach my $tryserver (keys(%servers)) { 4896: if (&reply('domroleput:'.$dom.':'. 4897: $domrolebuffer{$dom},$tryserver) eq 'ok') { 4898: last; 4899: } else { 4900: &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); 4901: } 4902: } 4903: } 4904: $dumpcount++; 4905: } 4906: 4907: sub courselog { 4908: my $what=shift; 4909: $what=time.':'.$what; 4910: unless ($env{'request.course.id'}) { return ''; } 4911: $coursedombuf{$env{'request.course.id'}}= 4912: $env{'course.'.$env{'request.course.id'}.'.domain'}; 4913: $coursenumbuf{$env{'request.course.id'}}= 4914: $env{'course.'.$env{'request.course.id'}.'.num'}; 4915: $coursehombuf{$env{'request.course.id'}}= 4916: $env{'course.'.$env{'request.course.id'}.'.home'}; 4917: $coursedescrbuf{$env{'request.course.id'}}= 4918: $env{'course.'.$env{'request.course.id'}.'.description'}; 4919: $courseinstcodebuf{$env{'request.course.id'}}= 4920: $env{'course.'.$env{'request.course.id'}.'.internal.coursecode'}; 4921: $courseownerbuf{$env{'request.course.id'}}= 4922: $env{'course.'.$env{'request.course.id'}.'.internal.courseowner'}; 4923: $coursetypebuf{$env{'request.course.id'}}= 4924: $env{'course.'.$env{'request.course.id'}.'.type'}; 4925: if (defined $courselogs{$env{'request.course.id'}}) { 4926: $courselogs{$env{'request.course.id'}}.='&'.$what; 4927: } else { 4928: $courselogs{$env{'request.course.id'}}.=$what; 4929: } 4930: if (length($courselogs{$env{'request.course.id'}})>4048) { 4931: &flushcourselogs(); 4932: } 4933: } 4934: 4935: sub courseacclog { 4936: my $fnsymb=shift; 4937: unless ($env{'request.course.id'}) { return ''; } 4938: my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; 4939: if ($fnsymb=~/$LONCAPA::assess_re/) { 4940: $what.=':POST'; 4941: # FIXME: Probably ought to escape things.... 4942: foreach my $key (keys(%env)) { 4943: if ($key=~/^form\.(.*)/) { 4944: my $formitem = $1; 4945: if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) { 4946: $what.=':'.$formitem.'='.$env{$key}; 4947: } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) { 4948: $what.=':'.$formitem.'='.$env{$key}; 4949: } 4950: } 4951: } 4952: } elsif ($fnsymb =~ m:^/adm/searchcat:) { 4953: # FIXME: We should not be depending on a form parameter that someone 4954: # editing lonsearchcat.pm might change in the future. 4955: if ($env{'form.phase'} eq 'course_search') { 4956: $what.= ':POST'; 4957: # FIXME: Probably ought to escape things.... 4958: foreach my $element ('courseexp','crsfulltext','crsrelated', 4959: 'crsdiscuss') { 4960: $what.=':'.$element.'='.$env{'form.'.$element}; 4961: } 4962: } 4963: } 4964: &courselog($what); 4965: } 4966: 4967: sub countacc { 4968: my $url=&declutter(shift); 4969: return if (! defined($url) || $url eq ''); 4970: unless ($env{'request.course.id'}) { return ''; } 4971: # 4972: # Mark that this url was used in this course 4973: # 4974: $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; 4975: # 4976: # Increase the access count for this resource in this child process 4977: # 4978: my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; 4979: $accesshash{$key}++; 4980: } 4981: 4982: sub linklog { 4983: my ($from,$to)=@_; 4984: $from=&declutter($from); 4985: $to=&declutter($to); 4986: $accesshash{$from.'___'.$to.'___comefrom'}=1; 4987: $accesshash{$to.'___'.$from.'___goto'}=1; 4988: } 4989: 4990: sub statslog { 4991: my ($symb,$part,$users,$av_attempts,$degdiff)=@_; 4992: if ($users<2) { return; } 4993: my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({ 4994: 'course' => $env{'request.course.id'}, 4995: 'sections' => '"all"', 4996: 'num_students' => $users, 4997: 'part' => $part, 4998: 'symb' => $symb, 4999: 'mean_tries' => $av_attempts, 5000: 'deg_of_diff' => $degdiff}); 5001: foreach my $key (keys(%dynstore)) { 5002: $accesshash{$key}=$dynstore{$key}; 5003: } 5004: } 5005: 5006: sub userrolelog { 5007: my ($trole,$username,$domain,$area,$tstart,$tend)=@_; 5008: if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) { 5009: my (undef,$rudom,$runame,$rsec)=split(/\//,$area); 5010: $userrolehash 5011: {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} 5012: =$tend.':'.$tstart; 5013: } 5014: if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) { 5015: $userrolehash 5016: {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} 5017: =$tend.':'.$tstart; 5018: } 5019: if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) { 5020: my (undef,$rudom,$runame,$rsec)=split(/\//,$area); 5021: $domainrolehash 5022: {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} 5023: = $tend.':'.$tstart; 5024: } 5025: } 5026: 5027: sub courserolelog { 5028: my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_; 5029: if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { 5030: my $cdom = $1; 5031: my $cnum = $2; 5032: my $sec = $3; 5033: my $namespace = 'rolelog'; 5034: my %storehash = ( 5035: role => $trole, 5036: start => $tstart, 5037: end => $tend, 5038: selfenroll => $selfenroll, 5039: context => $context, 5040: ); 5041: if ($trole eq 'gr') { 5042: $namespace = 'groupslog'; 5043: $storehash{'group'} = $sec; 5044: } else { 5045: $storehash{'section'} = $sec; 5046: } 5047: &write_log('course',$namespace,\%storehash,$delflag,$username, 5048: $domain,$cnum,$cdom); 5049: if (($trole ne 'st') || ($sec ne '')) { 5050: &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); 5051: } 5052: } 5053: return; 5054: } 5055: 5056: sub domainrolelog { 5057: my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; 5058: if ($area =~ m{^/($match_domain)/$}) { 5059: my $cdom = $1; 5060: my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom); 5061: my $namespace = 'rolelog'; 5062: my %storehash = ( 5063: role => $trole, 5064: start => $tstart, 5065: end => $tend, 5066: context => $context, 5067: ); 5068: &write_log('domain',$namespace,\%storehash,$delflag,$username, 5069: $domain,$domconfiguser,$cdom); 5070: } 5071: return; 5072: 5073: } 5074: 5075: sub coauthorrolelog { 5076: my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; 5077: if ($area =~ m{^/($match_domain)/($match_username)$}) { 5078: my $audom = $1; 5079: my $auname = $2; 5080: my $namespace = 'rolelog'; 5081: my %storehash = ( 5082: role => $trole, 5083: start => $tstart, 5084: end => $tend, 5085: context => $context, 5086: ); 5087: &write_log('author',$namespace,\%storehash,$delflag,$username, 5088: $domain,$auname,$audom); 5089: } 5090: return; 5091: } 5092: 5093: sub get_course_adv_roles { 5094: my ($cid,$codes) = @_; 5095: $cid=$env{'request.course.id'} unless (defined($cid)); 5096: my %coursehash=&coursedescription($cid); 5097: my $crstype = &Apache::loncommon::course_type($cid); 5098: my %nothide=(); 5099: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { 5100: if ($user !~ /:/) { 5101: $nothide{join(':',split(/[\@]/,$user))}=1; 5102: } else { 5103: $nothide{$user}=1; 5104: } 5105: } 5106: my @possdoms = ($coursehash{'domain'}); 5107: if ($coursehash{'checkforpriv'}) { 5108: push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); 5109: } 5110: my %returnhash=(); 5111: my %dumphash= 5112: &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); 5113: my $now=time; 5114: my %privileged; 5115: foreach my $entry (keys(%dumphash)) { 5116: my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); 5117: if (($tstart) && ($tstart<0)) { next; } 5118: if (($tend) && ($tend<$now)) { next; } 5119: if (($tstart) && ($now<$tstart)) { next; } 5120: my ($role,$username,$domain,$section)=split(/\:/,$entry); 5121: if ($username eq '' || $domain eq '') { next; } 5122: if ((&privileged($username,$domain,\@possdoms)) && 5123: (!$nothide{$username.':'.$domain})) { next; } 5124: if ($role eq 'cr') { next; } 5125: if ($codes) { 5126: if ($section) { $role .= ':'.$section; } 5127: if ($returnhash{$role}) { 5128: $returnhash{$role}.=','.$username.':'.$domain; 5129: } else { 5130: $returnhash{$role}=$username.':'.$domain; 5131: } 5132: } else { 5133: my $key=&plaintext($role,$crstype); 5134: if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } 5135: if ($returnhash{$key}) { 5136: $returnhash{$key}.=','.$username.':'.$domain; 5137: } else { 5138: $returnhash{$key}=$username.':'.$domain; 5139: } 5140: } 5141: } 5142: return %returnhash; 5143: } 5144: 5145: sub get_my_roles { 5146: my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_; 5147: unless (defined($uname)) { $uname=$env{'user.name'}; } 5148: unless (defined($udom)) { $udom=$env{'user.domain'}; } 5149: my (%dumphash,%nothide); 5150: if ($context eq 'userroles') { 5151: %dumphash = &dump('roles',$udom,$uname); 5152: } else { 5153: %dumphash = &dump('nohist_userroles',$udom,$uname); 5154: if ($hidepriv) { 5155: my %coursehash=&coursedescription($udom.'_'.$uname); 5156: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { 5157: if ($user !~ /:/) { 5158: $nothide{join(':',split(/[\@]/,$user))} = 1; 5159: } else { 5160: $nothide{$user} = 1; 5161: } 5162: } 5163: } 5164: } 5165: my %returnhash=(); 5166: my $now=time; 5167: my %privileged; 5168: foreach my $entry (keys(%dumphash)) { 5169: my ($role,$tend,$tstart); 5170: if ($context eq 'userroles') { 5171: next if ($entry =~ /^rolesdef/); 5172: ($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); 5173: } else { 5174: ($tend,$tstart)=split(/\:/,$dumphash{$entry}); 5175: } 5176: if (($tstart) && ($tstart<0)) { next; } 5177: my $status = 'active'; 5178: if (($tend) && ($tend<=$now)) { 5179: $status = 'previous'; 5180: } 5181: if (($tstart) && ($now<$tstart)) { 5182: $status = 'future'; 5183: } 5184: if (ref($types) eq 'ARRAY') { 5185: if (!grep(/^\Q$status\E$/,@{$types})) { 5186: next; 5187: } 5188: } else { 5189: if ($status ne 'active') { 5190: next; 5191: } 5192: } 5193: my ($rolecode,$username,$domain,$section,$area); 5194: if ($context eq 'userroles') { 5195: ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/); 5196: (undef,$domain,$username,$section) = split(/\//,$area); 5197: } else { 5198: ($role,$username,$domain,$section) = split(/\:/,$entry); 5199: } 5200: if (ref($roledoms) eq 'ARRAY') { 5201: if (!grep(/^\Q$domain\E$/,@{$roledoms})) { 5202: next; 5203: } 5204: } 5205: if (ref($roles) eq 'ARRAY') { 5206: if (!grep(/^\Q$role\E$/,@{$roles})) { 5207: if ($role =~ /^cr\//) { 5208: if (!grep(/^cr$/,@{$roles})) { 5209: next; 5210: } 5211: } elsif ($role =~ /^gr\//) { 5212: if (!grep(/^gr$/,@{$roles})) { 5213: next; 5214: } 5215: } else { 5216: next; 5217: } 5218: } 5219: } 5220: if ($hidepriv) { 5221: my @privroles = ('dc','su'); 5222: if ($context eq 'userroles') { 5223: next if (grep(/^\Q$role\E$/,@privroles)); 5224: } else { 5225: my $possdoms = [$domain]; 5226: if (ref($roledoms) eq 'ARRAY') { 5227: push(@{$possdoms},@{$roledoms}); 5228: } 5229: if (&privileged($username,$domain,$possdoms,\@privroles)) { 5230: if (!$nothide{$username.':'.$domain}) { 5231: next; 5232: } 5233: } 5234: } 5235: } 5236: if ($withsec) { 5237: $returnhash{$username.':'.$domain.':'.$role.':'.$section} = 5238: $tstart.':'.$tend; 5239: } else { 5240: $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; 5241: } 5242: } 5243: return %returnhash; 5244: } 5245: 5246: sub get_all_adhocroles { 5247: my ($dom) = @_; 5248: my @roles_by_num = (); 5249: my %domdefaults = &get_domain_defaults($dom); 5250: my (%description,%access_in_dom,%access_info); 5251: if (ref($domdefaults{'adhocroles'}) eq 'HASH') { 5252: my $count = 0; 5253: my %domcurrent = %{$domdefaults{'adhocroles'}}; 5254: my %ordered; 5255: foreach my $role (sort(keys(%domcurrent))) { 5256: my ($order,$desc,$access_in_dom); 5257: if (ref($domcurrent{$role}) eq 'HASH') { 5258: $order = $domcurrent{$role}{'order'}; 5259: $desc = $domcurrent{$role}{'desc'}; 5260: $access_in_dom{$role} = $domcurrent{$role}{'access'}; 5261: $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}}; 5262: } 5263: if ($order eq '') { 5264: $order = $count; 5265: } 5266: $ordered{$order} = $role; 5267: if ($desc ne '') { 5268: $description{$role} = $desc; 5269: } else { 5270: $description{$role}= $role; 5271: } 5272: $count++; 5273: } 5274: foreach my $item (sort {$a <=> $b } (keys(%ordered))) { 5275: push(@roles_by_num,$ordered{$item}); 5276: } 5277: } 5278: return (\@roles_by_num,\%description,\%access_in_dom,\%access_info); 5279: } 5280: 5281: sub get_my_adhocroles { 5282: my ($cid,$checkreg) = @_; 5283: my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num); 5284: if ($env{'request.course.id'} eq $cid) { 5285: $cdom = $env{'course.'.$cid.'.domain'}; 5286: $cnum = $env{'course.'.$cid.'.num'}; 5287: $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'}; 5288: } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) { 5289: $cdom = $1; 5290: $cnum = $2; 5291: %info = &Apache::lonnet::get('environment',['internal.coursecode'], 5292: $cdom,$cnum); 5293: } 5294: if (($info{'internal.coursecode'} ne '') && ($checkreg)) { 5295: my $user = $env{'user.name'}.':'.$env{'user.domain'}; 5296: my %rosterhash = &get('classlist',[$user],$cdom,$cnum); 5297: if ($rosterhash{$user} ne '') { 5298: my $type = (split(/:/,$rosterhash{$user}))[5]; 5299: return ([],{}) if ($type eq 'auto'); 5300: } 5301: } 5302: if (($cdom ne '') && ($cnum ne '')) { 5303: if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) { 5304: my $then=$env{'user.login.time'}; 5305: my $update=$env{'user.update.time'}; 5306: if (!$update) { 5307: $update = $then; 5308: } 5309: my @liveroles; 5310: foreach my $role ('dh','da') { 5311: if ($env{"user.role.$role./$cdom/"}) { 5312: my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"}); 5313: my $limit = $update; 5314: if ($env{'request.role'} eq "$role./$cdom/") { 5315: $limit = $then; 5316: } 5317: my $activerole = 1; 5318: if ($tstart && $tstart>$limit) { $activerole = 0; } 5319: if ($tend && $tend <$limit) { $activerole = 0; } 5320: if ($activerole) { 5321: push(@liveroles,$role); 5322: } 5323: } 5324: } 5325: if (@liveroles) { 5326: if (&homeserver($cnum,$cdom) ne 'no_host') { 5327: my ($accessref,$accessinfo,%access_in_dom); 5328: ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); 5329: if (ref($roles_by_num) eq 'ARRAY') { 5330: if (@{$roles_by_num}) { 5331: my %settings; 5332: if ($env{'request.course.id'} eq $cid) { 5333: foreach my $envkey (keys(%env)) { 5334: if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) { 5335: $settings{$1} = $env{$envkey}; 5336: } 5337: } 5338: } else { 5339: %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc'); 5340: } 5341: my %setincrs; 5342: if ($settings{'internal.adhocaccess'}) { 5343: map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'}); 5344: } 5345: my @statuses; 5346: if ($env{'environment.inststatus'}) { 5347: @statuses = split(/,/,$env{'environment.inststatus'}); 5348: } 5349: my $user = $env{'user.name'}.':'.$env{'user.domain'}; 5350: if (ref($accessref) eq 'HASH') { 5351: %access_in_dom = %{$accessref}; 5352: } 5353: foreach my $role (@{$roles_by_num}) { 5354: my ($curraccess,@okstatus,@personnel); 5355: if ($setincrs{$role}) { 5356: ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role}); 5357: if ($curraccess eq 'status') { 5358: @okstatus = split(/\&/,$rest); 5359: } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { 5360: @personnel = split(/\&/,$rest); 5361: } 5362: } else { 5363: $curraccess = $access_in_dom{$role}; 5364: if (ref($accessinfo) eq 'HASH') { 5365: if ($curraccess eq 'status') { 5366: if (ref($accessinfo->{$role}) eq 'ARRAY') { 5367: @okstatus = @{$accessinfo->{$role}}; 5368: } 5369: } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { 5370: if (ref($accessinfo->{$role}) eq 'ARRAY') { 5371: @personnel = @{$accessinfo->{$role}}; 5372: } 5373: } 5374: } 5375: } 5376: if ($curraccess eq 'none') { 5377: next; 5378: } elsif ($curraccess eq 'all') { 5379: push(@possroles,$role); 5380: } elsif ($curraccess eq 'dh') { 5381: if (grep(/^dh$/,@liveroles)) { 5382: push(@possroles,$role); 5383: } else { 5384: next; 5385: } 5386: } elsif ($curraccess eq 'da') { 5387: if (grep(/^da$/,@liveroles)) { 5388: push(@possroles,$role); 5389: } else { 5390: next; 5391: } 5392: } elsif ($curraccess eq 'status') { 5393: if (@okstatus) { 5394: if (!@statuses) { 5395: if (grep(/^default$/,@okstatus)) { 5396: push(@possroles,$role); 5397: } 5398: } else { 5399: foreach my $status (@okstatus) { 5400: if (grep(/^\Q$status\E$/,@statuses)) { 5401: push(@possroles,$role); 5402: last; 5403: } 5404: } 5405: } 5406: } 5407: } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { 5408: if (grep(/^\Q$user\E$/,@personnel)) { 5409: if ($curraccess eq 'exc') { 5410: push(@possroles,$role); 5411: } 5412: } elsif ($curraccess eq 'inc') { 5413: push(@possroles,$role); 5414: } 5415: } 5416: } 5417: } 5418: } 5419: } 5420: } 5421: } 5422: } 5423: unless (ref($description) eq 'HASH') { 5424: if (ref($roles_by_num) eq 'ARRAY') { 5425: my %desc; 5426: map { $desc{$_} = $_; } (@{$roles_by_num}); 5427: $description = \%desc; 5428: } else { 5429: $description = {}; 5430: } 5431: } 5432: return (\@possroles,$description); 5433: } 5434: 5435: # ----------------------------------------------------- Frontpage Announcements 5436: # 5437: # 5438: 5439: sub postannounce { 5440: my ($server,$text)=@_; 5441: unless (&allowed('psa',&host_domain($server))) { return 'refused'; } 5442: unless ($text=~/\w/) { $text=''; } 5443: return &reply('setannounce:'.&escape($text),$server); 5444: } 5445: 5446: sub getannounce { 5447: 5448: if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) { 5449: my $announcement=''; 5450: while (my $line = <$fh>) { $announcement .= $line; } 5451: close($fh); 5452: if ($announcement=~/\w/) { 5453: return 5454: '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'. 5455: '<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>'; 5456: } else { 5457: return ''; 5458: } 5459: } else { 5460: return ''; 5461: } 5462: } 5463: 5464: # ---------------------------------------------------------- Course ID routines 5465: # Deal with domain's nohist_courseid.db files 5466: # 5467: 5468: sub courseidput { 5469: my ($domain,$storehash,$coursehome,$caller) = @_; 5470: return unless (ref($storehash) eq 'HASH'); 5471: my $outcome; 5472: if ($caller eq 'timeonly') { 5473: my $cids = ''; 5474: foreach my $item (keys(%$storehash)) { 5475: $cids.=&escape($item).'&'; 5476: } 5477: $cids=~s/\&$//; 5478: $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids, 5479: $coursehome); 5480: } else { 5481: my $items = ''; 5482: foreach my $item (keys(%$storehash)) { 5483: $items.= &escape($item).'='. 5484: &freeze_escape($$storehash{$item}).'&'; 5485: } 5486: $items=~s/\&$//; 5487: $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items, 5488: $coursehome); 5489: } 5490: if ($outcome eq 'unknown_cmd') { 5491: my $what; 5492: foreach my $cid (keys(%$storehash)) { 5493: $what .= &escape($cid).'='; 5494: foreach my $item ('description','inst_code','owner','type') { 5495: $what .= &escape($storehash->{$cid}{$item}).':'; 5496: } 5497: $what =~ s/\:$/&/; 5498: } 5499: $what =~ s/\&$//; 5500: return &reply('courseidput:'.$domain.':'.$what,$coursehome); 5501: } else { 5502: return $outcome; 5503: } 5504: } 5505: 5506: sub courseiddump { 5507: my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, 5508: $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, 5509: $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, 5510: $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, 5511: $hasuniquecode,$reqcrsdom,$reqinstcode)=@_; 5512: my $as_hash = 1; 5513: my %returnhash; 5514: if (!$domfilter) { $domfilter=''; } 5515: my %libserv = &all_library(); 5516: foreach my $tryserver (keys(%libserv)) { 5517: if ( ( $hostidflag == 1 5518: && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) 5519: || (!defined($hostidflag)) ) { 5520: 5521: if (($domfilter eq '') || 5522: (&host_domain($tryserver) eq $domfilter)) { 5523: my $rep; 5524: if (grep { $_ eq $tryserver } current_machine_ids()) { 5525: $rep = LONCAPA::Lond::dump_course_id_handler( 5526: join(":", (&host_domain($tryserver), $sincefilter, 5527: &escape($descfilter), &escape($instcodefilter), 5528: &escape($ownerfilter), &escape($coursefilter), 5529: &escape($typefilter), &escape($regexp_ok), 5530: $as_hash, &escape($selfenrollonly), 5531: &escape($catfilter), $showhidden, $caller, 5532: &escape($cloner), &escape($cc_clone), $cloneonly, 5533: &escape($createdbefore), &escape($createdafter), 5534: &escape($creationcontext),$domcloner,$hasuniquecode, 5535: $reqcrsdom,&escape($reqinstcode)))); 5536: } else { 5537: $rep = &reply('courseiddump:'.&host_domain($tryserver).':'. 5538: $sincefilter.':'.&escape($descfilter).':'. 5539: &escape($instcodefilter).':'.&escape($ownerfilter). 5540: ':'.&escape($coursefilter).':'.&escape($typefilter). 5541: ':'.&escape($regexp_ok).':'.$as_hash.':'. 5542: &escape($selfenrollonly).':'.&escape($catfilter).':'. 5543: $showhidden.':'.$caller.':'.&escape($cloner).':'. 5544: &escape($cc_clone).':'.$cloneonly.':'. 5545: &escape($createdbefore).':'.&escape($createdafter).':'. 5546: &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. 5547: ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); 5548: } 5549: 5550: my @pairs=split(/\&/,$rep); 5551: foreach my $item (@pairs) { 5552: my ($key,$value)=split(/\=/,$item,2); 5553: $key = &unescape($key); 5554: next if ($key =~ /^error: 2 /); 5555: my $result = &thaw_unescape($value); 5556: if (ref($result) eq 'HASH') { 5557: $returnhash{$key}=$result; 5558: } else { 5559: my @responses = split(/:/,$value); 5560: my @items = ('description','inst_code','owner','type'); 5561: for (my $i=0; $i<@responses; $i++) { 5562: $returnhash{$key}{$items[$i]} = &unescape($responses[$i]); 5563: } 5564: } 5565: } 5566: } 5567: } 5568: } 5569: return %returnhash; 5570: } 5571: 5572: sub courselastaccess { 5573: my ($cdom,$cnum,$hostidref) = @_; 5574: my %returnhash; 5575: if ($cdom && $cnum) { 5576: my $chome = &homeserver($cnum,$cdom); 5577: if ($chome ne 'no_host') { 5578: my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome); 5579: &extract_lastaccess(\%returnhash,$rep); 5580: } 5581: } else { 5582: if (!$cdom) { $cdom=''; } 5583: my %libserv = &all_library(); 5584: foreach my $tryserver (keys(%libserv)) { 5585: if (ref($hostidref) eq 'ARRAY') { 5586: next unless (grep(/^\Q$tryserver\E$/,@{$hostidref})); 5587: } 5588: if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) { 5589: my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver); 5590: &extract_lastaccess(\%returnhash,$rep); 5591: } 5592: } 5593: } 5594: return %returnhash; 5595: } 5596: 5597: sub extract_lastaccess { 5598: my ($returnhash,$rep) = @_; 5599: if (ref($returnhash) eq 'HASH') { 5600: unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || 5601: $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' || 5602: $rep eq '') { 5603: my @pairs=split(/\&/,$rep); 5604: foreach my $item (@pairs) { 5605: my ($key,$value)=split(/\=/,$item,2); 5606: $key = &unescape($key); 5607: next if ($key =~ /^error: 2 /); 5608: $returnhash->{$key} = &thaw_unescape($value); 5609: } 5610: } 5611: } 5612: return; 5613: } 5614: 5615: # ---------------------------------------------------------- DC e-mail 5616: 5617: sub dcmailput { 5618: my ($domain,$msgid,$message,$server)=@_; 5619: my $status = &Apache::lonnet::critical( 5620: 'dcmailput:'.$domain.':'.&escape($msgid).'='. 5621: &escape($message),$server); 5622: return $status; 5623: } 5624: 5625: sub dcmaildump { 5626: my ($dom,$startdate,$enddate,$senders) = @_; 5627: my %returnhash=(); 5628: 5629: if (defined(&domain($dom,'primary'))) { 5630: my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. 5631: &escape($enddate).':'; 5632: my @esc_senders=map { &escape($_)} @$senders; 5633: $cmd.=&escape(join('&',@esc_senders)); 5634: foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) { 5635: my ($key,$value) = split(/\=/,$line,2); 5636: if (($key) && ($value)) { 5637: $returnhash{&unescape($key)} = &unescape($value); 5638: } 5639: } 5640: } 5641: return %returnhash; 5642: } 5643: # ---------------------------------------------------------- Domain roles 5644: 5645: sub get_domain_roles { 5646: my ($dom,$roles,$startdate,$enddate)=@_; 5647: if ((!defined($startdate)) || ($startdate eq '')) { 5648: $startdate = '.'; 5649: } 5650: if ((!defined($enddate)) || ($enddate eq '')) { 5651: $enddate = '.'; 5652: } 5653: my $rolelist; 5654: if (ref($roles) eq 'ARRAY') { 5655: $rolelist = join('&',@{$roles}); 5656: } 5657: my %personnel = (); 5658: 5659: my %servers = &get_servers($dom,'library'); 5660: foreach my $tryserver (keys(%servers)) { 5661: %{$personnel{$tryserver}}=(); 5662: foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'. 5663: &escape($startdate).':'. 5664: &escape($enddate).':'. 5665: &escape($rolelist), $tryserver))) { 5666: my ($key,$value) = split(/\=/,$line,2); 5667: if (($key) && ($value)) { 5668: $personnel{$tryserver}{&unescape($key)} = &unescape($value); 5669: } 5670: } 5671: } 5672: return %personnel; 5673: } 5674: 5675: sub get_active_domroles { 5676: my ($dom,$roles) = @_; 5677: return () unless (ref($roles) eq 'ARRAY'); 5678: my $now = time; 5679: my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now); 5680: my %domroles; 5681: foreach my $server (keys(%dompersonnel)) { 5682: foreach my $user (sort(keys(%{$dompersonnel{$server}}))) { 5683: my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user); 5684: $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user}; 5685: } 5686: } 5687: return %domroles; 5688: } 5689: 5690: # ----------------------------------------------------------- Interval timing 5691: 5692: { 5693: # Caches needed for speedup of navmaps 5694: # We don't want to cache this for very long at all (5 seconds at most) 5695: # 5696: # The user for whom we cache 5697: my $cachedkey=''; 5698: # The cached times for this user 5699: my %cachedtimes=(); 5700: # When this was last done 5701: my $cachedtime=''; 5702: 5703: sub load_all_first_access { 5704: my ($uname,$udom,$ignorecache)=@_; 5705: if (($cachedkey eq $uname.':'.$udom) && 5706: (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) && 5707: (!$ignorecache)) { 5708: return; 5709: } 5710: $cachedtime=time; 5711: $cachedkey=$uname.':'.$udom; 5712: %cachedtimes=&dump('firstaccesstimes',$udom,$uname); 5713: } 5714: 5715: sub get_first_access { 5716: my ($type,$argsymb,$argmap,$ignorecache)=@_; 5717: my ($symb,$courseid,$udom,$uname)=&whichuser(); 5718: if ($argsymb) { $symb=$argsymb; } 5719: my ($map,$id,$res)=&decode_symb($symb); 5720: if ($argmap) { $map = $argmap; } 5721: if ($type eq 'course') { 5722: $res='course'; 5723: } elsif ($type eq 'map') { 5724: $res=&symbread($map); 5725: } else { 5726: $res=$symb; 5727: } 5728: &load_all_first_access($uname,$udom,$ignorecache); 5729: return $cachedtimes{"$courseid\0$res"}; 5730: } 5731: 5732: sub set_first_access { 5733: my ($type,$interval)=@_; 5734: my ($symb,$courseid,$udom,$uname)=&whichuser(); 5735: my ($map,$id,$res)=&decode_symb($symb); 5736: if ($type eq 'course') { 5737: $res='course'; 5738: } elsif ($type eq 'map') { 5739: $res=&symbread($map); 5740: } else { 5741: $res=$symb; 5742: } 5743: $cachedkey=''; 5744: my $firstaccess=&get_first_access($type,$symb,$map); 5745: if ($firstaccess) { 5746: &logthis("First access time already set ($firstaccess) when attempting ". 5747: "to set new value (type: $type, extent: $res) for $uname:$udom ". 5748: "in $courseid"); 5749: return 'already_set'; 5750: } else { 5751: my $start = time; 5752: my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start}, 5753: $udom,$uname); 5754: if ($putres eq 'ok') { 5755: &put('timerinterval',{"$courseid\0$res"=>$interval}, 5756: $udom,$uname); 5757: &appenv( 5758: { 5759: 'course.'.$courseid.'.firstaccess.'.$res => $start, 5760: 'course.'.$courseid.'.timerinterval.'.$res => $interval, 5761: } 5762: ); 5763: if (($cachedtime) && (abs($start-$cachedtime) < 5)) { 5764: $cachedtimes{"$courseid\0$res"} = $start; 5765: } 5766: } elsif ($putres ne 'refused') { 5767: &logthis("Result: $putres when attempting to set first access time ". 5768: "(type: $type, extent: $res) for $uname:$udom in $courseid"); 5769: } 5770: return $putres; 5771: } 5772: return 'already_set'; 5773: } 5774: } 5775: 5776: # --------------------------------------------- Set Expire Date for Spreadsheet 5777: 5778: sub expirespread { 5779: my ($uname,$udom,$stype,$usymb)=@_; 5780: my $cid=$env{'request.course.id'}; 5781: if ($cid) { 5782: my $now=time; 5783: my $key=$uname.':'.$udom.':'.$stype.':'.$usymb; 5784: return &reply('put:'.$env{'course.'.$cid.'.domain'}.':'. 5785: $env{'course.'.$cid.'.num'}. 5786: ':nohist_expirationdates:'. 5787: &escape($key).'='.$now, 5788: $env{'course.'.$cid.'.home'}) 5789: } 5790: return 'ok'; 5791: } 5792: 5793: # ----------------------------------------------------- Devalidate Spreadsheets 5794: 5795: sub devalidate { 5796: my ($symb,$uname,$udom)=@_; 5797: my $cid=$env{'request.course.id'}; 5798: if ($cid) { 5799: # delete the stored spreadsheets for 5800: # - the student level sheet of this user in course's homespace 5801: # - the assessment level sheet for this resource 5802: # for this user in user's homespace 5803: # - current conditional state info 5804: my $key=$uname.':'.$udom.':'; 5805: my $status= 5806: &del('nohist_calculatedsheets', 5807: [$key.'studentcalc:'], 5808: $env{'course.'.$cid.'.domain'}, 5809: $env{'course.'.$cid.'.num'}) 5810: .' '. 5811: &del('nohist_calculatedsheets_'.$cid, 5812: [$key.'assesscalc:'.$symb],$udom,$uname); 5813: unless ($status eq 'ok ok') { 5814: &logthis('Could not devalidate spreadsheet '. 5815: $uname.' at '.$udom.' for '. 5816: $symb.': '.$status); 5817: } 5818: &delenv('user.state.'.$cid); 5819: } 5820: } 5821: 5822: sub get_scalar { 5823: my ($string,$end) = @_; 5824: my $value; 5825: if ($$string =~ s/^([^&]*?)($end)/$2/) { 5826: $value = $1; 5827: } elsif ($$string =~ s/^([^&]*?)&//) { 5828: $value = $1; 5829: } 5830: return &unescape($value); 5831: } 5832: 5833: sub array2str { 5834: my (@array) = @_; 5835: my $result=&arrayref2str(\@array); 5836: $result=~s/^__ARRAY_REF__//; 5837: $result=~s/__END_ARRAY_REF__$//; 5838: return $result; 5839: } 5840: 5841: sub arrayref2str { 5842: my ($arrayref) = @_; 5843: my $result='__ARRAY_REF__'; 5844: foreach my $elem (@$arrayref) { 5845: if(ref($elem) eq 'ARRAY') { 5846: $result.=&arrayref2str($elem).'&'; 5847: } elsif(ref($elem) eq 'HASH') { 5848: $result.=&hashref2str($elem).'&'; 5849: } elsif(ref($elem)) { 5850: #print("Got a ref of ".(ref($elem))." skipping."); 5851: } else { 5852: $result.=&escape($elem).'&'; 5853: } 5854: } 5855: $result=~s/\&$//; 5856: $result .= '__END_ARRAY_REF__'; 5857: return $result; 5858: } 5859: 5860: sub hash2str { 5861: my (%hash) = @_; 5862: my $result=&hashref2str(\%hash); 5863: $result=~s/^__HASH_REF__//; 5864: $result=~s/__END_HASH_REF__$//; 5865: return $result; 5866: } 5867: 5868: sub hashref2str { 5869: my ($hashref)=@_; 5870: my $result='__HASH_REF__'; 5871: foreach my $key (sort(keys(%$hashref))) { 5872: if (ref($key) eq 'ARRAY') { 5873: $result.=&arrayref2str($key).'='; 5874: } elsif (ref($key) eq 'HASH') { 5875: $result.=&hashref2str($key).'='; 5876: } elsif (ref($key)) { 5877: $result.='='; 5878: #print("Got a ref of ".(ref($key))." skipping."); 5879: } else { 5880: if (defined($key)) {$result.=&escape($key).'=';} else { last; } 5881: } 5882: 5883: if(ref($hashref->{$key}) eq 'ARRAY') { 5884: $result.=&arrayref2str($hashref->{$key}).'&'; 5885: } elsif(ref($hashref->{$key}) eq 'HASH') { 5886: $result.=&hashref2str($hashref->{$key}).'&'; 5887: } elsif(ref($hashref->{$key})) { 5888: $result.='&'; 5889: #print("Got a ref of ".(ref($hashref->{$key}))." skipping."); 5890: } else { 5891: $result.=&escape($hashref->{$key}).'&'; 5892: } 5893: } 5894: $result=~s/\&$//; 5895: $result .= '__END_HASH_REF__'; 5896: return $result; 5897: } 5898: 5899: sub str2hash { 5900: my ($string)=@_; 5901: my ($hash)=&str2hashref('__HASH_REF__'.$string.'__END_HASH_REF__'); 5902: return %$hash; 5903: } 5904: 5905: sub str2hashref { 5906: my ($string) = @_; 5907: 5908: my %hash; 5909: 5910: if($string !~ /^__HASH_REF__/) { 5911: if (! ($string eq '' || !defined($string))) { 5912: $hash{'error'}='Not hash reference'; 5913: } 5914: return (\%hash, $string); 5915: } 5916: 5917: $string =~ s/^__HASH_REF__//; 5918: 5919: while($string !~ /^__END_HASH_REF__/) { 5920: #key 5921: my $key=''; 5922: if($string =~ /^__HASH_REF__/) { 5923: ($key, $string)=&str2hashref($string); 5924: if(defined($key->{'error'})) { 5925: $hash{'error'}='Bad data'; 5926: return (\%hash, $string); 5927: } 5928: } elsif($string =~ /^__ARRAY_REF__/) { 5929: ($key, $string)=&str2arrayref($string); 5930: if($key->[0] eq 'Array reference error') { 5931: $hash{'error'}='Bad data'; 5932: return (\%hash, $string); 5933: } 5934: } else { 5935: $string =~ s/^(.*?)=//; 5936: $key=&unescape($1); 5937: } 5938: $string =~ s/^=//; 5939: 5940: #value 5941: my $value=''; 5942: if($string =~ /^__HASH_REF__/) { 5943: ($value, $string)=&str2hashref($string); 5944: if(defined($value->{'error'})) { 5945: $hash{'error'}='Bad data'; 5946: return (\%hash, $string); 5947: } 5948: } elsif($string =~ /^__ARRAY_REF__/) { 5949: ($value, $string)=&str2arrayref($string); 5950: if($value->[0] eq 'Array reference error') { 5951: $hash{'error'}='Bad data'; 5952: return (\%hash, $string); 5953: } 5954: } else { 5955: $value=&get_scalar(\$string,'__END_HASH_REF__'); 5956: } 5957: $string =~ s/^&//; 5958: 5959: $hash{$key}=$value; 5960: } 5961: 5962: $string =~ s/^__END_HASH_REF__//; 5963: 5964: return (\%hash, $string); 5965: } 5966: 5967: sub str2array { 5968: my ($string)=@_; 5969: my ($array)=&str2arrayref('__ARRAY_REF__'.$string.'__END_ARRAY_REF__'); 5970: return @$array; 5971: } 5972: 5973: sub str2arrayref { 5974: my ($string) = @_; 5975: my @array; 5976: 5977: if($string !~ /^__ARRAY_REF__/) { 5978: if (! ($string eq '' || !defined($string))) { 5979: $array[0]='Array reference error'; 5980: } 5981: return (\@array, $string); 5982: } 5983: 5984: $string =~ s/^__ARRAY_REF__//; 5985: 5986: while($string !~ /^__END_ARRAY_REF__/) { 5987: my $value=''; 5988: if($string =~ /^__HASH_REF__/) { 5989: ($value, $string)=&str2hashref($string); 5990: if(defined($value->{'error'})) { 5991: $array[0] ='Array reference error'; 5992: return (\@array, $string); 5993: } 5994: } elsif($string =~ /^__ARRAY_REF__/) { 5995: ($value, $string)=&str2arrayref($string); 5996: if($value->[0] eq 'Array reference error') { 5997: $array[0] ='Array reference error'; 5998: return (\@array, $string); 5999: } 6000: } else { 6001: $value=&get_scalar(\$string,'__END_ARRAY_REF__'); 6002: } 6003: $string =~ s/^&//; 6004: 6005: push(@array, $value); 6006: } 6007: 6008: $string =~ s/^__END_ARRAY_REF__//; 6009: 6010: return (\@array, $string); 6011: } 6012: 6013: # -------------------------------------------------------------------Temp Store 6014: 6015: sub tmpreset { 6016: my ($symb,$namespace,$domain,$stuname) = @_; 6017: if (!$symb) { 6018: $symb=&symbread(); 6019: if (!$symb) { $symb= $env{'request.url'}; } 6020: } 6021: $symb=escape($symb); 6022: 6023: if (!$namespace) { $namespace=$env{'request.state'}; } 6024: $namespace=~s/\//\_/g; 6025: $namespace=~s/\W//g; 6026: 6027: if (!$domain) { $domain=$env{'user.domain'}; } 6028: if (!$stuname) { $stuname=$env{'user.name'}; } 6029: if ($domain eq 'public' && $stuname eq 'public') { 6030: $stuname=$ENV{'REMOTE_ADDR'}; 6031: } 6032: my $path=LONCAPA::tempdir(); 6033: my %hash; 6034: if (tie(%hash,'GDBM_File', 6035: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 6036: &GDBM_WRCREAT(),0640)) { 6037: foreach my $key (keys(%hash)) { 6038: if ($key=~ /:$symb/) { 6039: delete($hash{$key}); 6040: } 6041: } 6042: } 6043: } 6044: 6045: sub tmpstore { 6046: my ($storehash,$symb,$namespace,$domain,$stuname) = @_; 6047: 6048: if (!$symb) { 6049: $symb=&symbread(); 6050: if (!$symb) { $symb= $env{'request.url'}; } 6051: } 6052: $symb=escape($symb); 6053: 6054: if (!$namespace) { 6055: # I don't think we would ever want to store this for a course. 6056: # it seems this will only be used if we don't have a course. 6057: #$namespace=$env{'request.course.id'}; 6058: #if (!$namespace) { 6059: $namespace=$env{'request.state'}; 6060: #} 6061: } 6062: $namespace=~s/\//\_/g; 6063: $namespace=~s/\W//g; 6064: if (!$domain) { $domain=$env{'user.domain'}; } 6065: if (!$stuname) { $stuname=$env{'user.name'}; } 6066: if ($domain eq 'public' && $stuname eq 'public') { 6067: $stuname=$ENV{'REMOTE_ADDR'}; 6068: } 6069: my $now=time; 6070: my %hash; 6071: my $path=LONCAPA::tempdir(); 6072: if (tie(%hash,'GDBM_File', 6073: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 6074: &GDBM_WRCREAT(),0640)) { 6075: $hash{"version:$symb"}++; 6076: my $version=$hash{"version:$symb"}; 6077: my $allkeys=''; 6078: foreach my $key (keys(%$storehash)) { 6079: $allkeys.=$key.':'; 6080: $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key}); 6081: } 6082: $hash{"$version:$symb:timestamp"}=$now; 6083: $allkeys.='timestamp'; 6084: $hash{"$version:keys:$symb"}=$allkeys; 6085: if (untie(%hash)) { 6086: return 'ok'; 6087: } else { 6088: return "error:$!"; 6089: } 6090: } else { 6091: return "error:$!"; 6092: } 6093: } 6094: 6095: # -----------------------------------------------------------------Temp Restore 6096: 6097: sub tmprestore { 6098: my ($symb,$namespace,$domain,$stuname) = @_; 6099: 6100: if (!$symb) { 6101: $symb=&symbread(); 6102: if (!$symb) { $symb= $env{'request.url'}; } 6103: } 6104: $symb=escape($symb); 6105: 6106: if (!$namespace) { $namespace=$env{'request.state'}; } 6107: 6108: if (!$domain) { $domain=$env{'user.domain'}; } 6109: if (!$stuname) { $stuname=$env{'user.name'}; } 6110: if ($domain eq 'public' && $stuname eq 'public') { 6111: $stuname=$ENV{'REMOTE_ADDR'}; 6112: } 6113: my %returnhash; 6114: $namespace=~s/\//\_/g; 6115: $namespace=~s/\W//g; 6116: my %hash; 6117: my $path=LONCAPA::tempdir(); 6118: if (tie(%hash,'GDBM_File', 6119: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', 6120: &GDBM_READER(),0640)) { 6121: my $version=$hash{"version:$symb"}; 6122: $returnhash{'version'}=$version; 6123: my $scope; 6124: for ($scope=1;$scope<=$version;$scope++) { 6125: my $vkeys=$hash{"$scope:keys:$symb"}; 6126: my @keys=split(/:/,$vkeys); 6127: my $key; 6128: $returnhash{"$scope:keys"}=$vkeys; 6129: foreach $key (@keys) { 6130: $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); 6131: $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); 6132: } 6133: } 6134: if (!(untie(%hash))) { 6135: return "error:$!"; 6136: } 6137: } else { 6138: return "error:$!"; 6139: } 6140: return %returnhash; 6141: } 6142: 6143: # ----------------------------------------------------------------------- Store 6144: 6145: sub store { 6146: my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_; 6147: my $home=''; 6148: 6149: if ($stuname) { $home=&homeserver($stuname,$domain); } 6150: 6151: $symb=&symbclean($symb); 6152: if (!$symb) { unless ($symb=&symbread()) { return ''; } } 6153: 6154: if (!$domain) { $domain=$env{'user.domain'}; } 6155: if (!$stuname) { $stuname=$env{'user.name'}; } 6156: 6157: &devalidate($symb,$stuname,$domain); 6158: 6159: $symb=escape($symb); 6160: if (!$namespace) { 6161: unless ($namespace=$env{'request.course.id'}) { 6162: return ''; 6163: } 6164: } 6165: if (!$home) { $home=$env{'user.home'}; } 6166: 6167: $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; 6168: $$storehash{'host'}=$perlvar{'lonHostID'}; 6169: 6170: my $namevalue=''; 6171: foreach my $key (keys(%$storehash)) { 6172: $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; 6173: } 6174: $namevalue=~s/\&$//; 6175: &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); 6176: return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home"); 6177: } 6178: 6179: # -------------------------------------------------------------- Critical Store 6180: 6181: sub cstore { 6182: my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_; 6183: my $home=''; 6184: 6185: if ($stuname) { $home=&homeserver($stuname,$domain); } 6186: 6187: $symb=&symbclean($symb); 6188: if (!$symb) { unless ($symb=&symbread()) { return ''; } } 6189: 6190: if (!$domain) { $domain=$env{'user.domain'}; } 6191: if (!$stuname) { $stuname=$env{'user.name'}; } 6192: 6193: &devalidate($symb,$stuname,$domain); 6194: 6195: $symb=escape($symb); 6196: if (!$namespace) { 6197: unless ($namespace=$env{'request.course.id'}) { 6198: return ''; 6199: } 6200: } 6201: if (!$home) { $home=$env{'user.home'}; } 6202: 6203: $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; 6204: $$storehash{'host'}=$perlvar{'lonHostID'}; 6205: 6206: my $namevalue=''; 6207: foreach my $key (keys(%$storehash)) { 6208: $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; 6209: } 6210: $namevalue=~s/\&$//; 6211: &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); 6212: return critical 6213: ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home"); 6214: } 6215: 6216: # --------------------------------------------------------------------- Restore 6217: 6218: sub restore { 6219: my ($symb,$namespace,$domain,$stuname) = @_; 6220: my $home=''; 6221: 6222: if ($stuname) { $home=&homeserver($stuname,$domain); } 6223: 6224: if (!$symb) { 6225: return if ($namespace eq 'courserequests'); 6226: unless ($symb=escape(&symbread())) { return ''; } 6227: } else { 6228: unless ($namespace eq 'courserequests') { 6229: $symb=&escape(&symbclean($symb)); 6230: } 6231: } 6232: if (!$namespace) { 6233: unless ($namespace=$env{'request.course.id'}) { 6234: return ''; 6235: } 6236: } 6237: if (!$domain) { $domain=$env{'user.domain'}; } 6238: if (!$stuname) { $stuname=$env{'user.name'}; } 6239: if (!$home) { $home=$env{'user.home'}; } 6240: my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); 6241: 6242: my %returnhash=(); 6243: foreach my $line (split(/\&/,$answer)) { 6244: my ($name,$value)=split(/\=/,$line); 6245: $returnhash{&unescape($name)}=&thaw_unescape($value); 6246: } 6247: my $version; 6248: for ($version=1;$version<=$returnhash{'version'};$version++) { 6249: foreach my $item (split(/\:/,$returnhash{$version.':keys'})) { 6250: $returnhash{$item}=$returnhash{$version.':'.$item}; 6251: } 6252: } 6253: return %returnhash; 6254: } 6255: 6256: # ---------------------------------------------------------- Course Description 6257: # 6258: # 6259: 6260: sub coursedescription { 6261: my ($courseid,$args)=@_; 6262: $courseid=~s/^\///; 6263: $courseid=~s/\_/\//g; 6264: my ($cdomain,$cnum)=split(/\//,$courseid); 6265: my $chome=&homeserver($cnum,$cdomain); 6266: my $normalid=$cdomain.'_'.$cnum; 6267: # need to always cache even if we get errors otherwise we keep 6268: # trying and trying and trying to get the course description. 6269: my %envhash=(); 6270: my %returnhash=(); 6271: 6272: my $expiretime=600; 6273: if ($env{'request.course.id'} eq $normalid) { 6274: $expiretime=120; 6275: } 6276: 6277: my $prefix='course.'.$cdomain.'_'.$cnum.'.'; 6278: if (!$args->{'freshen_cache'} 6279: && ((time-$env{$prefix.'last_cache'}) < $expiretime) ) { 6280: foreach my $key (keys(%env)) { 6281: next if ($key !~ /^\Q$prefix\E(.*)/); 6282: my ($setting) = $1; 6283: $returnhash{$setting} = $env{$key}; 6284: } 6285: return %returnhash; 6286: } 6287: 6288: # get the data again 6289: 6290: if (!$args->{'one_time'}) { 6291: $envhash{'course.'.$normalid.'.last_cache'}=time; 6292: } 6293: 6294: if ($chome ne 'no_host') { 6295: %returnhash=&dump('environment',$cdomain,$cnum); 6296: if (!exists($returnhash{'con_lost'})) { 6297: my $username = $env{'user.name'}; # Defult username 6298: if(defined $args->{'user'}) { 6299: $username = $args->{'user'}; 6300: } 6301: $returnhash{'home'}= $chome; 6302: $returnhash{'domain'} = $cdomain; 6303: $returnhash{'num'} = $cnum; 6304: if (!defined($returnhash{'type'})) { 6305: $returnhash{'type'} = 'Course'; 6306: } 6307: while (my ($name,$value) = each %returnhash) { 6308: $envhash{'course.'.$normalid.'.'.$name}=$value; 6309: } 6310: $returnhash{'url'}=&clutter($returnhash{'url'}); 6311: $returnhash{'fn'}=LONCAPA::tempdir() . 6312: $username.'_'.$cdomain.'_'.$cnum; 6313: $envhash{'course.'.$normalid.'.home'}=$chome; 6314: $envhash{'course.'.$normalid.'.domain'}=$cdomain; 6315: $envhash{'course.'.$normalid.'.num'}=$cnum; 6316: } 6317: } 6318: if (!$args->{'one_time'}) { 6319: &appenv(\%envhash); 6320: } 6321: return %returnhash; 6322: } 6323: 6324: sub update_released_required { 6325: my ($needsrelease,$cdom,$cnum,$chome,$cid) = @_; 6326: if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') { 6327: $cid = $env{'request.course.id'}; 6328: $cdom = $env{'course.'.$cid.'.domain'}; 6329: $cnum = $env{'course.'.$cid.'.num'}; 6330: $chome = $env{'course.'.$cid.'.home'}; 6331: } 6332: if ($needsrelease) { 6333: my %curr_reqd_hash = &userenvironment($cdom,$cnum,'internal.releaserequired'); 6334: my $needsupdate; 6335: if ($curr_reqd_hash{'internal.releaserequired'} eq '') { 6336: $needsupdate = 1; 6337: } else { 6338: my ($currmajor,$currminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); 6339: my ($needsmajor,$needsminor) = split(/\./,$needsrelease); 6340: if (($currmajor < $needsmajor) || ($currmajor == $needsmajor && $currminor < $needsminor)) { 6341: $needsupdate = 1; 6342: } 6343: } 6344: if ($needsupdate) { 6345: my %needshash = ( 6346: 'internal.releaserequired' => $needsrelease, 6347: ); 6348: my $putresult = &put('environment',\%needshash,$cdom,$cnum); 6349: if ($putresult eq 'ok') { 6350: &appenv({'course.'.$cid.'.internal.releaserequired' => $needsrelease}); 6351: my %crsinfo = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); 6352: if (ref($crsinfo{$cid}) eq 'HASH') { 6353: $crsinfo{$cid}{'releaserequired'} = $needsrelease; 6354: &courseidput($cdom,\%crsinfo,$chome,'notime'); 6355: } 6356: } 6357: } 6358: } 6359: return; 6360: } 6361: 6362: # -------------------------------------------------See if a user is privileged 6363: 6364: sub privileged { 6365: my ($username,$domain,$possdomains,$possroles)=@_; 6366: my $now = time; 6367: my $roles; 6368: if (ref($possroles) eq 'ARRAY') { 6369: $roles = $possroles; 6370: } else { 6371: $roles = ['dc','su']; 6372: } 6373: if (ref($possdomains) eq 'ARRAY') { 6374: my %privileged = &privileged_by_domain($possdomains,$roles); 6375: foreach my $dom (@{$possdomains}) { 6376: if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) && 6377: (ref($privileged{$dom}) eq 'HASH')) { 6378: foreach my $role (@{$roles}) { 6379: if (ref($privileged{$dom}{$role}) eq 'HASH') { 6380: if (exists($privileged{$dom}{$role}{$username.':'.$domain})) { 6381: my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain}); 6382: return 1 unless (($end && $end < $now) || 6383: ($start && $start > $now)); 6384: } 6385: } 6386: } 6387: } 6388: } 6389: } else { 6390: my %rolesdump = &dump("roles", $domain, $username) or return 0; 6391: my $now = time; 6392: 6393: for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) { 6394: my ($trole, $tend, $tstart) = split(/_/, $role); 6395: if (grep(/^\Q$trole\E$/,@{$roles})) { 6396: return 1 unless ($tend && $tend < $now) 6397: or ($tstart && $tstart > $now); 6398: } 6399: } 6400: } 6401: return 0; 6402: } 6403: 6404: sub privileged_by_domain { 6405: my ($domains,$roles) = @_; 6406: my %privileged = (); 6407: my $cachetime = 60*60*24; 6408: my $now = time; 6409: unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) { 6410: return %privileged; 6411: } 6412: foreach my $dom (@{$domains}) { 6413: next if (ref($privileged{$dom}) eq 'HASH'); 6414: my $needroles; 6415: foreach my $role (@{$roles}) { 6416: my ($result,$cached)=&is_cached_new('priv_'.$role,$dom); 6417: if (defined($cached)) { 6418: if (ref($result) eq 'HASH') { 6419: $privileged{$dom}{$role} = $result; 6420: } 6421: } else { 6422: $needroles = 1; 6423: } 6424: } 6425: if ($needroles) { 6426: my %dompersonnel = &get_domain_roles($dom,$roles); 6427: $privileged{$dom} = {}; 6428: foreach my $server (keys(%dompersonnel)) { 6429: if (ref($dompersonnel{$server}) eq 'HASH') { 6430: foreach my $item (keys(%{$dompersonnel{$server}})) { 6431: my ($trole,$uname,$udom,$rest) = split(/:/,$item,4); 6432: my ($end,$start) = split(/:/,$dompersonnel{$server}{$item}); 6433: next if ($end && $end < $now); 6434: $privileged{$dom}{$trole}{$uname.':'.$udom} = 6435: $dompersonnel{$server}{$item}; 6436: } 6437: } 6438: } 6439: if (ref($privileged{$dom}) eq 'HASH') { 6440: foreach my $role (@{$roles}) { 6441: if (ref($privileged{$dom}{$role}) eq 'HASH') { 6442: &do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime); 6443: } else { 6444: my %hash = (); 6445: &do_cache_new('priv_'.$role,$dom,\%hash,$cachetime); 6446: } 6447: } 6448: } 6449: } 6450: } 6451: return %privileged; 6452: } 6453: 6454: # -------------------------------------------------------- Get user privileges 6455: 6456: sub rolesinit { 6457: my ($domain, $username) = @_; 6458: my %userroles = ('user.login.time' => time); 6459: my %rolesdump = &dump("roles", $domain, $username) or return \%userroles; 6460: 6461: # firstaccess and timerinterval are related to timed maps/resources. 6462: # also, blocking can be triggered by an activating timer 6463: # it's saved in the user's %env. 6464: my %firstaccess = &dump('firstaccesstimes', $domain, $username); 6465: my %timerinterval = &dump('timerinterval', $domain, $username); 6466: my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals, 6467: %timerintchk, %timerintenv); 6468: 6469: foreach my $key (keys(%firstaccess)) { 6470: my ($cid, $rest) = split(/\0/, $key); 6471: $coursetimerstarts{$cid}{$rest} = $firstaccess{$key}; 6472: } 6473: 6474: foreach my $key (keys(%timerinterval)) { 6475: my ($cid,$rest) = split(/\0/,$key); 6476: $coursetimerintervals{$cid}{$rest} = $timerinterval{$key}; 6477: } 6478: 6479: my %allroles=(); 6480: my %allgroups=(); 6481: 6482: for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) { 6483: my $role = $rolesdump{$area}; 6484: $area =~ s/\_\w\w$//; 6485: 6486: my ($trole, $tend, $tstart, $group_privs); 6487: 6488: if ($role =~ /^cr/) { 6489: # Custom role, defined by a user 6490: # e.g., user.role.cr/msu/smith/mynewrole 6491: if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) { 6492: $trole = $1; 6493: ($tend, $tstart) = split('_', $2); 6494: } else { 6495: $trole = $role; 6496: } 6497: } elsif ($role =~ m|^gr/|) { 6498: # Role of member in a group, defined within a course/community 6499: # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards 6500: ($trole, $tend, $tstart) = split(/_/, $role); 6501: next if $tstart eq '-1'; 6502: ($trole, $group_privs) = split(/\//, $trole); 6503: $group_privs = &unescape($group_privs); 6504: } else { 6505: # Just a normal role, defined in roles.tab 6506: ($trole, $tend, $tstart) = split(/_/,$role); 6507: } 6508: 6509: my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain, 6510: $username); 6511: @userroles{keys(%new_role)} = @new_role{keys(%new_role)}; 6512: 6513: # role expired or not available yet? 6514: $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or 6515: ($tstart != 0 && $tstart > $userroles{'user.login.time'}); 6516: 6517: next if $area eq '' or $trole eq ''; 6518: 6519: my $spec = "$trole.$area"; 6520: my ($tdummy, $tdomain, $trest) = split(/\//, $area); 6521: 6522: if ($trole =~ /^cr\//) { 6523: # Custom role, defined by a user 6524: &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); 6525: } elsif ($trole eq 'gr') { 6526: # Role of a member in a group, defined within a course/community 6527: &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart); 6528: next; 6529: } else { 6530: # Normal role, defined in roles.tab 6531: &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); 6532: } 6533: 6534: my $cid = $tdomain.'_'.$trest; 6535: unless ($firstaccchk{$cid}) { 6536: if (ref($coursetimerstarts{$cid}) eq 'HASH') { 6537: foreach my $item (keys(%{$coursetimerstarts{$cid}})) { 6538: $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 6539: $coursetimerstarts{$cid}{$item}; 6540: } 6541: } 6542: $firstaccchk{$cid} = 1; 6543: } 6544: unless ($timerintchk{$cid}) { 6545: if (ref($coursetimerintervals{$cid}) eq 'HASH') { 6546: foreach my $item (keys(%{$coursetimerintervals{$cid}})) { 6547: $timerintenv{'course.'.$cid.'.timerinterval.'.$item} = 6548: $coursetimerintervals{$cid}{$item}; 6549: } 6550: } 6551: $timerintchk{$cid} = 1; 6552: } 6553: } 6554: 6555: @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, 6556: \%allroles, \%allgroups); 6557: $env{'user.adv'} = $userroles{'user.adv'}; 6558: $env{'user.rar'} = $userroles{'user.rar'}; 6559: 6560: return (\%userroles,\%firstaccenv,\%timerintenv); 6561: } 6562: 6563: sub set_arearole { 6564: my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_; 6565: unless ($nolog) { 6566: # log the associated role with the area 6567: &userrolelog($trole,$username,$domain,$area,$tstart,$tend); 6568: } 6569: return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend); 6570: } 6571: 6572: sub custom_roleprivs { 6573: my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; 6574: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); 6575: my $homsvr = &homeserver($rauthor,$rdomain); 6576: if (&hostname($homsvr) ne '') { 6577: my ($rdummy,$roledef)= 6578: &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); 6579: if (($rdummy ne 'con_lost') && ($roledef ne '')) { 6580: my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); 6581: if (defined($syspriv)) { 6582: if ($trest =~ /^$match_community$/) { 6583: $syspriv =~ s/bre\&S//; 6584: } 6585: $$allroles{'cm./'}.=':'.$syspriv; 6586: $$allroles{$spec.'./'}.=':'.$syspriv; 6587: } 6588: if ($tdomain ne '') { 6589: if (defined($dompriv)) { 6590: $$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv; 6591: $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; 6592: } 6593: if (($trest ne '') && (defined($coursepriv))) { 6594: if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) { 6595: my $rolename = $1; 6596: $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv); 6597: } 6598: $$allroles{'cm.'.$area}.=':'.$coursepriv; 6599: $$allroles{$spec.'.'.$area}.=':'.$coursepriv; 6600: } 6601: } 6602: } 6603: } 6604: } 6605: 6606: sub course_adhocrole_privs { 6607: my ($rolename,$cdom,$cnum,$coursepriv) = @_; 6608: my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum); 6609: if ($overrides{"internal.adhocpriv.$rolename"}) { 6610: my (%currprivs,%storeprivs); 6611: foreach my $item (split(/:/,$coursepriv)) { 6612: my ($priv,$restrict) = split(/\&/,$item); 6613: $currprivs{$priv} = $restrict; 6614: } 6615: my (%possadd,%possremove,%full); 6616: foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) { 6617: my ($priv,$restrict)=split(/\&/,$item); 6618: $full{$priv} = $restrict; 6619: } 6620: foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) { 6621: next if ($item eq ''); 6622: my ($rule,$rest) = split(/=/,$item); 6623: next unless (($rule eq 'off') || ($rule eq 'on')); 6624: foreach my $priv (split(/:/,$rest)) { 6625: if ($priv ne '') { 6626: if ($rule eq 'off') { 6627: $possremove{$priv} = 1; 6628: } else { 6629: $possadd{$priv} = 1; 6630: } 6631: } 6632: } 6633: } 6634: foreach my $priv (sort(keys(%full))) { 6635: if (exists($currprivs{$priv})) { 6636: unless (exists($possremove{$priv})) { 6637: $storeprivs{$priv} = $currprivs{$priv}; 6638: } 6639: } elsif (exists($possadd{$priv})) { 6640: $storeprivs{$priv} = $full{$priv}; 6641: } 6642: } 6643: $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs))); 6644: } 6645: return $coursepriv; 6646: } 6647: 6648: sub group_roleprivs { 6649: my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; 6650: my $access = 1; 6651: my $now = time; 6652: if (($tend!=0) && ($tend<$now)) { $access = 0; } 6653: if (($tstart!=0) && ($tstart>$now)) { $access=0; } 6654: if ($access) { 6655: my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|); 6656: $$allgroups{$course}{$group} .=':'.$group_privs; 6657: } 6658: } 6659: 6660: sub standard_roleprivs { 6661: my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_; 6662: if (defined($pr{$trole.':s'})) { 6663: $$allroles{'cm./'}.=':'.$pr{$trole.':s'}; 6664: $$allroles{$spec.'./'}.=':'.$pr{$trole.':s'}; 6665: } 6666: if ($tdomain ne '') { 6667: if (defined($pr{$trole.':d'})) { 6668: $$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; 6669: $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'}; 6670: } 6671: if (($trest ne '') && (defined($pr{$trole.':c'}))) { 6672: $$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'}; 6673: $$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'}; 6674: } 6675: } 6676: } 6677: 6678: sub set_userprivs { 6679: my ($userroles,$allroles,$allgroups,$groups_roles) = @_; 6680: my $author=0; 6681: my $adv=0; 6682: my $rar=0; 6683: my %grouproles = (); 6684: if (keys(%{$allgroups}) > 0) { 6685: my @groupkeys; 6686: foreach my $role (keys(%{$allroles})) { 6687: push(@groupkeys,$role); 6688: } 6689: if (ref($groups_roles) eq 'HASH') { 6690: foreach my $key (keys(%{$groups_roles})) { 6691: unless (grep(/^\Q$key\E$/,@groupkeys)) { 6692: push(@groupkeys,$key); 6693: } 6694: } 6695: } 6696: if (@groupkeys > 0) { 6697: foreach my $role (@groupkeys) { 6698: my ($trole,$area,$sec,$extendedarea); 6699: if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { 6700: $trole = $1; 6701: $area = $2; 6702: $sec = $3; 6703: $extendedarea = $area.$sec; 6704: if (exists($$allgroups{$area})) { 6705: foreach my $group (keys(%{$$allgroups{$area}})) { 6706: my $spec = $trole.'.'.$extendedarea; 6707: $grouproles{$spec.'.'.$area.'/'.$group} = 6708: $$allgroups{$area}{$group}; 6709: } 6710: } 6711: } 6712: } 6713: } 6714: } 6715: foreach my $group (keys(%grouproles)) { 6716: $$allroles{$group} = $grouproles{$group}; 6717: } 6718: foreach my $role (keys(%{$allroles})) { 6719: my %thesepriv; 6720: if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; } 6721: foreach my $item (split(/:/,$$allroles{$role})) { 6722: if ($item ne '') { 6723: my ($privilege,$restrictions)=split(/&/,$item); 6724: if ($restrictions eq '') { 6725: $thesepriv{$privilege}='F'; 6726: } elsif ($thesepriv{$privilege} ne 'F') { 6727: $thesepriv{$privilege}.=$restrictions; 6728: } 6729: if ($thesepriv{'adv'} eq 'F') { $adv=1; } 6730: if ($thesepriv{'rar'} eq 'F') { $rar=1; } 6731: } 6732: } 6733: my $thesestr=''; 6734: foreach my $priv (sort(keys(%thesepriv))) { 6735: $thesestr.=':'.$priv.'&'.$thesepriv{$priv}; 6736: } 6737: $userroles->{'user.priv.'.$role} = $thesestr; 6738: } 6739: return ($author,$adv,$rar); 6740: } 6741: 6742: sub role_status { 6743: my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; 6744: if (exists($env{$rolekey}) && $env{$rolekey} ne '') { 6745: my ($one,$two) = split(m{\./},$rolekey,2); 6746: (undef,undef,$$role) = split(/\./,$one,3); 6747: unless (!defined($$role) || $$role eq '') { 6748: $$where = '/'.$two; 6749: $$trolecode=$$role.'.'.$$where; 6750: ($$tstart,$$tend)=split(/\./,$env{$rolekey}); 6751: $$tstatus='is'; 6752: if ($$tstart && $$tstart>$update) { 6753: $$tstatus='future'; 6754: if ($$tstart<$now) { 6755: if ($$tstart && $$tstart>$refresh) { 6756: if (($$where ne '') && ($$role ne '')) { 6757: my (%allroles,%allgroups,$group_privs, 6758: %groups_roles,@rolecodes); 6759: my %userroles = ( 6760: 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend 6761: ); 6762: @rolecodes = ('cm'); 6763: my $spec=$$role.'.'.$$where; 6764: my ($tdummy,$tdomain,$trest)=split(/\//,$$where); 6765: if ($$role =~ /^cr\//) { 6766: &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); 6767: push(@rolecodes,'cr'); 6768: } elsif ($$role eq 'gr') { 6769: push(@rolecodes,$$role); 6770: my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, 6771: $env{'user.name'}); 6772: my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2); 6773: (undef,my $group_privs) = split(/\//,$trole); 6774: $group_privs = &unescape($group_privs); 6775: &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); 6776: my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1); 6777: &get_groups_roles($tdomain,$trest, 6778: \%course_roles,\@rolecodes, 6779: \%groups_roles); 6780: } else { 6781: push(@rolecodes,$$role); 6782: &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); 6783: } 6784: my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, 6785: \%groups_roles); 6786: &appenv(\%userroles,\@rolecodes); 6787: &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); 6788: } 6789: } 6790: $$tstatus = 'is'; 6791: } 6792: } 6793: if ($$tend) { 6794: if ($$tend<$update) { 6795: $$tstatus='expired'; 6796: } elsif ($$tend<$now) { 6797: $$tstatus='will_not'; 6798: } 6799: } 6800: } 6801: } 6802: } 6803: 6804: sub get_groups_roles { 6805: my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_; 6806: return unless((ref($cdom_courseroles) eq 'HASH') && 6807: (ref($rolecodes) eq 'ARRAY') && 6808: (ref($groups_roles) eq 'HASH')); 6809: if (keys(%{$cdom_courseroles}) > 0) { 6810: my ($cnum) = ($rest =~ /^($match_courseid)/); 6811: if ($cdom ne '' && $cnum ne '') { 6812: foreach my $key (keys(%{$cdom_courseroles})) { 6813: if ($key =~ /^\Q$cnum\E:\Q$cdom\E:([^:]+):?([^:]*)/) { 6814: my $crsrole = $1; 6815: my $crssec = $2; 6816: if ($crsrole =~ /^cr/) { 6817: unless (grep(/^cr$/,@{$rolecodes})) { 6818: push(@{$rolecodes},'cr'); 6819: } 6820: } else { 6821: unless(grep(/^\Q$crsrole\E$/,@{$rolecodes})) { 6822: push(@{$rolecodes},$crsrole); 6823: } 6824: } 6825: my $rolekey = "$crsrole./$cdom/$cnum"; 6826: if ($crssec ne '') { 6827: $rolekey .= "/$crssec"; 6828: } 6829: $rolekey .= './'; 6830: $groups_roles->{$rolekey} = $rolecodes; 6831: } 6832: } 6833: } 6834: } 6835: return; 6836: } 6837: 6838: sub delete_env_groupprivs { 6839: my ($where,$courseroles,$possroles) = @_; 6840: return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY')); 6841: my ($dummy,$udom,$uname,$group) = split(/\//,$where); 6842: unless (ref($courseroles->{$udom}) eq 'HASH') { 6843: %{$courseroles->{$udom}} = 6844: &get_my_roles('','','userroles',['active'], 6845: $possroles,[$udom],1); 6846: } 6847: if (ref($courseroles->{$udom}) eq 'HASH') { 6848: foreach my $item (keys(%{$courseroles->{$udom}})) { 6849: my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item); 6850: my $area = '/'.$cdom.'/'.$cnum; 6851: my $privkey = "user.priv.$crsrole.$area"; 6852: if ($crssec ne '') { 6853: $privkey .= '/'.$crssec; 6854: } 6855: $privkey .= ".$area/$group"; 6856: &Apache::lonnet::delenv($privkey,undef,[$crsrole]); 6857: } 6858: } 6859: return; 6860: } 6861: 6862: sub check_adhoc_privs { 6863: my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_; 6864: my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; 6865: if ($sec) { 6866: $cckey .= '/'.$sec; 6867: } 6868: my $setprivs; 6869: if ($env{$cckey}) { 6870: my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); 6871: &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); 6872: unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { 6873: &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); 6874: $setprivs = 1; 6875: } 6876: } else { 6877: &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); 6878: $setprivs = 1; 6879: } 6880: return $setprivs; 6881: } 6882: 6883: sub set_adhoc_privileges { 6884: # role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role 6885: my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_; 6886: my $area = '/'.$dcdom.'/'.$pickedcourse; 6887: if ($sec ne '') { 6888: $area .= '/'.$sec; 6889: } 6890: my $spec = $role.'.'.$area; 6891: my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, 6892: $env{'user.name'},1); 6893: my %rolehash = (); 6894: if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) { 6895: my $rolename = $1; 6896: &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area); 6897: my %domdef = &get_domain_defaults($dcdom); 6898: if (ref($domdef{'adhocroles'}) eq 'HASH') { 6899: if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') { 6900: &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},}); 6901: } 6902: } 6903: } else { 6904: &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); 6905: } 6906: my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); 6907: &appenv(\%userroles,[$role,'cm']); 6908: &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); 6909: unless (($caller eq 'constructaccess' && $env{'request.course.id'}) || 6910: ($caller eq 'tiny')) { 6911: &appenv( {'request.role' => $spec, 6912: 'request.role.domain' => $dcdom, 6913: 'request.course.sec' => $sec, 6914: } 6915: ); 6916: my $tadv=0; 6917: if (&allowed('adv') eq 'F') { $tadv=1; } 6918: &appenv({'request.role.adv' => $tadv}); 6919: } 6920: } 6921: 6922: # --------------------------------------------------------------- get interface 6923: 6924: sub get { 6925: my ($namespace,$storearr,$udomain,$uname)=@_; 6926: my $items=''; 6927: foreach my $item (@$storearr) { 6928: $items.=&escape($item).'&'; 6929: } 6930: $items=~s/\&$//; 6931: if (!$udomain) { $udomain=$env{'user.domain'}; } 6932: if (!$uname) { $uname=$env{'user.name'}; } 6933: my $uhome=&homeserver($uname,$udomain); 6934: 6935: my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome); 6936: my @pairs=split(/\&/,$rep); 6937: if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { 6938: return @pairs; 6939: } 6940: my %returnhash=(); 6941: my $i=0; 6942: foreach my $item (@$storearr) { 6943: $returnhash{$item}=&thaw_unescape($pairs[$i]); 6944: $i++; 6945: } 6946: return %returnhash; 6947: } 6948: 6949: # --------------------------------------------------------------- del interface 6950: 6951: sub del { 6952: my ($namespace,$storearr,$udomain,$uname)=@_; 6953: my $items=''; 6954: foreach my $item (@$storearr) { 6955: $items.=&escape($item).'&'; 6956: } 6957: 6958: $items=~s/\&$//; 6959: if (!$udomain) { $udomain=$env{'user.domain'}; } 6960: if (!$uname) { $uname=$env{'user.name'}; } 6961: my $uhome=&homeserver($uname,$udomain); 6962: return &reply("del:$udomain:$uname:$namespace:$items",$uhome); 6963: } 6964: 6965: # -------------------------------------------------------------- dump interface 6966: 6967: sub unserialize { 6968: my ($rep, $escapedkeys) = @_; 6969: 6970: return {} if $rep =~ /^error/; 6971: 6972: my %returnhash=(); 6973: foreach my $item (split(/\&/,$rep)) { 6974: my ($key, $value) = split(/=/, $item, 2); 6975: $key = unescape($key) unless $escapedkeys; 6976: next if $key =~ /^error: 2 /; 6977: $returnhash{$key} = &thaw_unescape($value); 6978: } 6979: #return %returnhash; 6980: return \%returnhash; 6981: } 6982: 6983: # see Lond::dump_with_regexp 6984: # if $escapedkeys hash keys won't get unescaped. 6985: sub dump { 6986: my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; 6987: if (!$udomain) { $udomain=$env{'user.domain'}; } 6988: if (!$uname) { $uname=$env{'user.name'}; } 6989: my $uhome=&homeserver($uname,$udomain); 6990: 6991: if ($regexp) { 6992: $regexp=&escape($regexp); 6993: } else { 6994: $regexp='.'; 6995: } 6996: if (grep { $_ eq $uhome } current_machine_ids()) { 6997: # user is hosted on this machine 6998: my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, 6999: $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); 7000: return %{unserialize($reply, $escapedkeys)}; 7001: } 7002: my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); 7003: my @pairs=split(/\&/,$rep); 7004: my %returnhash=(); 7005: if (!($rep =~ /^error/ )) { 7006: foreach my $item (@pairs) { 7007: my ($key,$value)=split(/=/,$item,2); 7008: $key = unescape($key) unless $escapedkeys; 7009: #$key = &unescape($key); 7010: next if ($key =~ /^error: 2 /); 7011: $returnhash{$key}=&thaw_unescape($value); 7012: } 7013: } 7014: return %returnhash; 7015: } 7016: 7017: 7018: # --------------------------------------------------------- dumpstore interface 7019: 7020: sub dumpstore { 7021: my ($namespace,$udomain,$uname,$regexp,$range)=@_; 7022: # same as dump but keys must be escaped. They may contain colon separated 7023: # lists of values that may themself contain colons (e.g. symbs). 7024: return &dump($namespace, $udomain, $uname, $regexp, $range, 1); 7025: } 7026: 7027: # -------------------------------------------------------------- keys interface 7028: 7029: sub getkeys { 7030: my ($namespace,$udomain,$uname)=@_; 7031: if (!$udomain) { $udomain=$env{'user.domain'}; } 7032: if (!$uname) { $uname=$env{'user.name'}; } 7033: my $uhome=&homeserver($uname,$udomain); 7034: my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); 7035: my @keyarray=(); 7036: foreach my $key (split(/\&/,$rep)) { 7037: next if ($key =~ /^error: 2 /); 7038: push(@keyarray,&unescape($key)); 7039: } 7040: return @keyarray; 7041: } 7042: 7043: # --------------------------------------------------------------- currentdump 7044: sub currentdump { 7045: my ($courseid,$sdom,$sname)=@_; 7046: $courseid = $env{'request.course.id'} if (! defined($courseid)); 7047: $sdom = $env{'user.domain'} if (! defined($sdom)); 7048: $sname = $env{'user.name'} if (! defined($sname)); 7049: my $uhome = &homeserver($sname,$sdom); 7050: my $rep; 7051: 7052: if (grep { $_ eq $uhome } current_machine_ids()) { 7053: $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, 7054: $courseid))); 7055: } else { 7056: $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); 7057: } 7058: 7059: return if ($rep =~ /^(error:|no_such_host)/); 7060: # 7061: my %returnhash=(); 7062: # 7063: if ($rep eq 'unknown_cmd') { 7064: # an old lond will not know currentdump 7065: # Do a dump and make it look like a currentdump 7066: my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); 7067: return if ($tmp[0] =~ /^(error:|no_such_host)/); 7068: my %hash = @tmp; 7069: @tmp=(); 7070: %returnhash = %{&convert_dump_to_currentdump(\%hash)}; 7071: } else { 7072: my @pairs=split(/\&/,$rep); 7073: foreach my $pair (@pairs) { 7074: my ($key,$value)=split(/=/,$pair,2); 7075: my ($symb,$param) = split(/:/,$key); 7076: $returnhash{&unescape($symb)}->{&unescape($param)} = 7077: &thaw_unescape($value); 7078: } 7079: } 7080: return %returnhash; 7081: } 7082: 7083: sub convert_dump_to_currentdump{ 7084: my %hash = %{shift()}; 7085: my %returnhash; 7086: # Code ripped from lond, essentially. The only difference 7087: # here is the unescaping done by lonnet::dump(). Conceivably 7088: # we might run in to problems with parameter names =~ /^v\./ 7089: while (my ($key,$value) = each(%hash)) { 7090: my ($v,$symb,$param) = split(/:/,$key); 7091: $symb = &unescape($symb); 7092: $param = &unescape($param); 7093: next if ($v eq 'version' || $symb eq 'keys'); 7094: next if (exists($returnhash{$symb}) && 7095: exists($returnhash{$symb}->{$param}) && 7096: $returnhash{$symb}->{'v.'.$param} > $v); 7097: $returnhash{$symb}->{$param}=$value; 7098: $returnhash{$symb}->{'v.'.$param}=$v; 7099: } 7100: # 7101: # Remove all of the keys in the hashes which keep track of 7102: # the version of the parameter. 7103: while (my ($symb,$param_hash) = each(%returnhash)) { 7104: # use a foreach because we are going to delete from the hash. 7105: foreach my $key (keys(%$param_hash)) { 7106: delete($param_hash->{$key}) if ($key =~ /^v\./); 7107: } 7108: } 7109: return \%returnhash; 7110: } 7111: 7112: # ------------------------------------------------------ critical inc interface 7113: 7114: sub cinc { 7115: return &inc(@_,'critical'); 7116: } 7117: 7118: # --------------------------------------------------------------- inc interface 7119: 7120: sub inc { 7121: my ($namespace,$store,$udomain,$uname,$critical) = @_; 7122: if (!$udomain) { $udomain=$env{'user.domain'}; } 7123: if (!$uname) { $uname=$env{'user.name'}; } 7124: my $uhome=&homeserver($uname,$udomain); 7125: my $items=''; 7126: if (! ref($store)) { 7127: # got a single value, so use that instead 7128: $items = &escape($store).'=&'; 7129: } elsif (ref($store) eq 'SCALAR') { 7130: $items = &escape($$store).'=&'; 7131: } elsif (ref($store) eq 'ARRAY') { 7132: $items = join('=&',map {&escape($_);} @{$store}); 7133: } elsif (ref($store) eq 'HASH') { 7134: while (my($key,$value) = each(%{$store})) { 7135: $items.= &escape($key).'='.&escape($value).'&'; 7136: } 7137: } 7138: $items=~s/\&$//; 7139: if ($critical) { 7140: return &critical("inc:$udomain:$uname:$namespace:$items",$uhome); 7141: } else { 7142: return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); 7143: } 7144: } 7145: 7146: # --------------------------------------------------------------- put interface 7147: 7148: sub put { 7149: my ($namespace,$storehash,$udomain,$uname)=@_; 7150: if (!$udomain) { $udomain=$env{'user.domain'}; } 7151: if (!$uname) { $uname=$env{'user.name'}; } 7152: my $uhome=&homeserver($uname,$udomain); 7153: my $items=''; 7154: foreach my $item (keys(%$storehash)) { 7155: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; 7156: } 7157: $items=~s/\&$//; 7158: return &reply("put:$udomain:$uname:$namespace:$items",$uhome); 7159: } 7160: 7161: # ------------------------------------------------------------ newput interface 7162: 7163: sub newput { 7164: my ($namespace,$storehash,$udomain,$uname)=@_; 7165: if (!$udomain) { $udomain=$env{'user.domain'}; } 7166: if (!$uname) { $uname=$env{'user.name'}; } 7167: my $uhome=&homeserver($uname,$udomain); 7168: my $items=''; 7169: foreach my $key (keys(%$storehash)) { 7170: $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; 7171: } 7172: $items=~s/\&$//; 7173: return &reply("newput:$udomain:$uname:$namespace:$items",$uhome); 7174: } 7175: 7176: # --------------------------------------------------------- putstore interface 7177: 7178: sub putstore { 7179: my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_; 7180: if (!$udomain) { $udomain=$env{'user.domain'}; } 7181: if (!$uname) { $uname=$env{'user.name'}; } 7182: my $uhome=&homeserver($uname,$udomain); 7183: my $items=''; 7184: foreach my $key (keys(%$storehash)) { 7185: $items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&'; 7186: } 7187: $items=~s/\&$//; 7188: my $esc_symb=&escape($symb); 7189: my $esc_v=&escape($version); 7190: my $reply = 7191: &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items", 7192: $uhome); 7193: if (($tolog) && ($reply eq 'ok')) { 7194: my $namevalue=''; 7195: foreach my $key (keys(%{$storehash})) { 7196: $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&'; 7197: } 7198: $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}). 7199: '&host='.&escape($perlvar{'lonHostID'}). 7200: '&version='.$esc_v. 7201: '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'}); 7202: &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue); 7203: } 7204: if ($reply eq 'unknown_cmd') { 7205: # gfall back to way things use to be done 7206: return &old_putstore($namespace,$symb,$version,$storehash,$udomain, 7207: $uname); 7208: } 7209: return $reply; 7210: } 7211: 7212: sub old_putstore { 7213: my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_; 7214: if (!$udomain) { $udomain=$env{'user.domain'}; } 7215: if (!$uname) { $uname=$env{'user.name'}; } 7216: my $uhome=&homeserver($uname,$udomain); 7217: my %newstorehash; 7218: foreach my $item (keys(%$storehash)) { 7219: my $key = $version.':'.&escape($symb).':'.$item; 7220: $newstorehash{$key} = $storehash->{$item}; 7221: } 7222: my $items=''; 7223: my %allitems = (); 7224: foreach my $item (keys(%newstorehash)) { 7225: if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { 7226: my $key = $1.':keys:'.$2; 7227: $allitems{$key} .= $3.':'; 7228: } 7229: $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&'; 7230: } 7231: foreach my $item (keys(%allitems)) { 7232: $allitems{$item} =~ s/\:$//; 7233: $items.= $item.'='.$allitems{$item}.'&'; 7234: } 7235: $items=~s/\&$//; 7236: return &reply("put:$udomain:$uname:$namespace:$items",$uhome); 7237: } 7238: 7239: # ------------------------------------------------------ critical put interface 7240: 7241: sub cput { 7242: my ($namespace,$storehash,$udomain,$uname)=@_; 7243: if (!$udomain) { $udomain=$env{'user.domain'}; } 7244: if (!$uname) { $uname=$env{'user.name'}; } 7245: my $uhome=&homeserver($uname,$udomain); 7246: my $items=''; 7247: foreach my $item (keys(%$storehash)) { 7248: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; 7249: } 7250: $items=~s/\&$//; 7251: return &critical("put:$udomain:$uname:$namespace:$items",$uhome); 7252: } 7253: 7254: # -------------------------------------------------------------- eget interface 7255: 7256: sub eget { 7257: my ($namespace,$storearr,$udomain,$uname)=@_; 7258: my $items=''; 7259: foreach my $item (@$storearr) { 7260: $items.=&escape($item).'&'; 7261: } 7262: $items=~s/\&$//; 7263: if (!$udomain) { $udomain=$env{'user.domain'}; } 7264: if (!$uname) { $uname=$env{'user.name'}; } 7265: my $uhome=&homeserver($uname,$udomain); 7266: my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome); 7267: my @pairs=split(/\&/,$rep); 7268: my %returnhash=(); 7269: my $i=0; 7270: foreach my $item (@$storearr) { 7271: $returnhash{$item}=&thaw_unescape($pairs[$i]); 7272: $i++; 7273: } 7274: return %returnhash; 7275: } 7276: 7277: # ------------------------------------------------------------ tmpput interface 7278: sub tmpput { 7279: my ($storehash,$server,$context)=@_; 7280: my $items=''; 7281: foreach my $item (keys(%$storehash)) { 7282: $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; 7283: } 7284: $items=~s/\&$//; 7285: if (defined($context)) { 7286: $items .= ':'.&escape($context); 7287: } 7288: return &reply("tmpput:$items",$server); 7289: } 7290: 7291: # ------------------------------------------------------------ tmpget interface 7292: sub tmpget { 7293: my ($token,$server)=@_; 7294: if (!defined($server)) { $server = $perlvar{'lonHostID'}; } 7295: my $rep=&reply("tmpget:$token",$server); 7296: my %returnhash; 7297: if ($rep =~ /^(con_lost|error|no_such_host)/i) { 7298: return %returnhash; 7299: } 7300: foreach my $item (split(/\&/,$rep)) { 7301: my ($key,$value)=split(/=/,$item); 7302: $returnhash{&unescape($key)}=&thaw_unescape($value); 7303: } 7304: return %returnhash; 7305: } 7306: 7307: # ------------------------------------------------------------ tmpdel interface 7308: sub tmpdel { 7309: my ($token,$server)=@_; 7310: if (!defined($server)) { $server = $perlvar{'lonHostID'}; } 7311: return &reply("tmpdel:$token",$server); 7312: } 7313: 7314: # ------------------------------------------------------------ get_timebased_id 7315: 7316: sub get_timebased_id { 7317: my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries, 7318: $maxtries) = @_; 7319: my ($newid,$error,$dellock); 7320: unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) { 7321: return ('','ok','invalid call to get suffix'); 7322: } 7323: 7324: # set defaults for any optional args for which values were not supplied 7325: if ($who eq '') { 7326: $who = $env{'user.name'}.':'.$env{'user.domain'}; 7327: } 7328: if (!$locktries) { 7329: $locktries = 3; 7330: } 7331: if (!$maxtries) { 7332: $maxtries = 10; 7333: } 7334: 7335: if (($cdom eq '') || ($cnum eq '')) { 7336: if ($env{'request.course.id'}) { 7337: $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 7338: $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; 7339: } 7340: if (($cdom eq '') || ($cnum eq '')) { 7341: return ('','ok','call to get suffix not in course context'); 7342: } 7343: } 7344: 7345: # construct locking item 7346: my $lockhash = { 7347: $prefix."\0".'locked_'.$keyid => $who, 7348: }; 7349: my $tries = 0; 7350: 7351: # attempt to get lock on nohist_$namespace file 7352: my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); 7353: while (($gotlock ne 'ok') && $tries <$locktries) { 7354: $tries ++; 7355: sleep 1; 7356: $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); 7357: } 7358: 7359: # attempt to get unique identifier, based on current timestamp 7360: if ($gotlock eq 'ok') { 7361: my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix); 7362: my $id = time; 7363: $newid = $id; 7364: if ($idtype eq 'addcode') { 7365: $newid .= &sixnum_code(); 7366: } 7367: my $idtries = 0; 7368: while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) { 7369: if ($idtype eq 'concat') { 7370: $newid = $id.$idtries; 7371: } elsif ($idtype eq 'addcode') { 7372: $newid = $newid.&sixnum_code(); 7373: } else { 7374: $newid ++; 7375: } 7376: $idtries ++; 7377: } 7378: if (!exists($inuse{$prefix."\0".$newid})) { 7379: my %new_item = ( 7380: $prefix."\0".$newid => $who, 7381: ); 7382: my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item, 7383: $cdom,$cnum); 7384: if ($putresult ne 'ok') { 7385: undef($newid); 7386: $error = 'error saving new item: '.$putresult; 7387: } 7388: } else { 7389: undef($newid); 7390: $error = ('error: no unique suffix available for the new item '); 7391: } 7392: # remove lock 7393: my @del_lock = ($prefix."\0".'locked_'.$keyid); 7394: $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum); 7395: } else { 7396: $error = "error: could not obtain lockfile\n"; 7397: $dellock = 'ok'; 7398: if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) { 7399: $dellock = 'nolock'; 7400: } 7401: } 7402: return ($newid,$dellock,$error); 7403: } 7404: 7405: sub sixnum_code { 7406: my $code; 7407: for (0..6) { 7408: $code .= int( rand(9) ); 7409: } 7410: return $code; 7411: } 7412: 7413: # -------------------------------------------------- portfolio access checking 7414: 7415: sub portfolio_access { 7416: my ($requrl,$clientip) = @_; 7417: my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); 7418: my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip); 7419: if ($result) { 7420: my %setters; 7421: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { 7422: my ($startblock,$endblock) = 7423: &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom); 7424: if ($startblock && $endblock) { 7425: return 'B'; 7426: } 7427: } else { 7428: my ($startblock,$endblock) = 7429: &Apache::loncommon::blockcheck(\%setters,'port'); 7430: if ($startblock && $endblock) { 7431: return 'B'; 7432: } 7433: } 7434: } 7435: if ($result eq 'ok') { 7436: return 'F'; 7437: } elsif ($result =~ /^[^:]+:guest_/) { 7438: return 'A'; 7439: } 7440: return ''; 7441: } 7442: 7443: sub get_portfolio_access { 7444: my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_; 7445: 7446: if (!ref($access_hash)) { 7447: my $current_perms = &get_portfile_permissions($udom,$unum); 7448: my %access_controls = &get_access_controls($current_perms,$group, 7449: $file_name); 7450: $access_hash = $access_controls{$file_name}; 7451: } 7452: 7453: my ($public,$guest,@domains,@users,@courses,@groups,@ips); 7454: my $now = time; 7455: if (ref($access_hash) eq 'HASH') { 7456: foreach my $key (keys(%{$access_hash})) { 7457: my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); 7458: if ($start > $now) { 7459: next; 7460: } 7461: if ($end && $end<$now) { 7462: next; 7463: } 7464: if ($scope eq 'public') { 7465: $public = $key; 7466: last; 7467: } elsif ($scope eq 'guest') { 7468: $guest = $key; 7469: } elsif ($scope eq 'domains') { 7470: push(@domains,$key); 7471: } elsif ($scope eq 'users') { 7472: push(@users,$key); 7473: } elsif ($scope eq 'course') { 7474: push(@courses,$key); 7475: } elsif ($scope eq 'group') { 7476: push(@groups,$key); 7477: } elsif ($scope eq 'ip') { 7478: push(@ips,$key); 7479: } 7480: } 7481: if ($public) { 7482: return 'ok'; 7483: } elsif (@ips > 0) { 7484: my $allowed; 7485: foreach my $ipkey (@ips) { 7486: if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') { 7487: if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) { 7488: $allowed = 1; 7489: last; 7490: } 7491: } 7492: } 7493: if ($allowed) { 7494: return 'ok'; 7495: } 7496: } 7497: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { 7498: if ($guest) { 7499: return $guest; 7500: } 7501: } else { 7502: if (@domains > 0) { 7503: foreach my $domkey (@domains) { 7504: if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') { 7505: if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) { 7506: return 'ok'; 7507: } 7508: } 7509: } 7510: } 7511: if (@users > 0) { 7512: foreach my $userkey (@users) { 7513: if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') { 7514: foreach my $item (@{$access_hash->{$userkey}{'users'}}) { 7515: if (ref($item) eq 'HASH') { 7516: if (($item->{'uname'} eq $env{'user.name'}) && 7517: ($item->{'udom'} eq $env{'user.domain'})) { 7518: return 'ok'; 7519: } 7520: } 7521: } 7522: } 7523: } 7524: } 7525: my %roleshash; 7526: my @courses_and_groups = @courses; 7527: push(@courses_and_groups,@groups); 7528: if (@courses_and_groups > 0) { 7529: my (%allgroups,%allroles); 7530: my ($start,$end,$role,$sec,$group); 7531: foreach my $envkey (%env) { 7532: if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { 7533: my $cid = $2.'_'.$3; 7534: if ($1 eq 'gr') { 7535: $group = $4; 7536: $allgroups{$cid}{$group} = $env{$envkey}; 7537: } else { 7538: if ($4 eq '') { 7539: $sec = 'none'; 7540: } else { 7541: $sec = $4; 7542: } 7543: $allroles{$cid}{$1}{$sec} = $env{$envkey}; 7544: } 7545: } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) { 7546: my $cid = $2.'_'.$3; 7547: if ($4 eq '') { 7548: $sec = 'none'; 7549: } else { 7550: $sec = $4; 7551: } 7552: $allroles{$cid}{$1}{$sec} = $env{$envkey}; 7553: } 7554: } 7555: if (keys(%allroles) == 0) { 7556: return; 7557: } 7558: foreach my $key (@courses_and_groups) { 7559: my %content = %{$$access_hash{$key}}; 7560: my $cnum = $content{'number'}; 7561: my $cdom = $content{'domain'}; 7562: my $cid = $cdom.'_'.$cnum; 7563: if (!exists($allroles{$cid})) { 7564: next; 7565: } 7566: foreach my $role_id (keys(%{$content{'roles'}})) { 7567: my @sections = @{$content{'roles'}{$role_id}{'section'}}; 7568: my @groups = @{$content{'roles'}{$role_id}{'group'}}; 7569: my @status = @{$content{'roles'}{$role_id}{'access'}}; 7570: my @roles = @{$content{'roles'}{$role_id}{'role'}}; 7571: foreach my $role (keys(%{$allroles{$cid}})) { 7572: if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) { 7573: foreach my $sec (keys(%{$allroles{$cid}{$role}})) { 7574: if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') { 7575: if (grep/^all$/,@sections) { 7576: return 'ok'; 7577: } else { 7578: if (grep/^$sec$/,@sections) { 7579: return 'ok'; 7580: } 7581: } 7582: } 7583: } 7584: if (keys(%{$allgroups{$cid}}) == 0) { 7585: if (grep/^none$/,@groups) { 7586: return 'ok'; 7587: } 7588: } else { 7589: if (grep/^all$/,@groups) { 7590: return 'ok'; 7591: } 7592: foreach my $group (keys(%{$allgroups{$cid}})) { 7593: if (grep/^$group$/,@groups) { 7594: return 'ok'; 7595: } 7596: } 7597: } 7598: } 7599: } 7600: } 7601: } 7602: } 7603: if ($guest) { 7604: return $guest; 7605: } 7606: } 7607: } 7608: return; 7609: } 7610: 7611: sub course_group_datechecker { 7612: my ($dates,$now,$status) = @_; 7613: my ($start,$end) = split(/\./,$dates); 7614: if (!$start && !$end) { 7615: return 'ok'; 7616: } 7617: if (grep/^active$/,@{$status}) { 7618: if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) { 7619: return 'ok'; 7620: } 7621: } 7622: if (grep/^previous$/,@{$status}) { 7623: if ($end > $now ) { 7624: return 'ok'; 7625: } 7626: } 7627: if (grep/^future$/,@{$status}) { 7628: if ($start > $now) { 7629: return 'ok'; 7630: } 7631: } 7632: return; 7633: } 7634: 7635: sub parse_portfolio_url { 7636: my ($url) = @_; 7637: 7638: my ($type,$udom,$unum,$group,$file_name); 7639: 7640: if ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) { 7641: $type = 1; 7642: $udom = $1; 7643: $unum = $2; 7644: $file_name = $3; 7645: } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) { 7646: $type = 2; 7647: $udom = $1; 7648: $unum = $2; 7649: $group = $3; 7650: $file_name = $3.'/'.$4; 7651: } 7652: if (wantarray) { 7653: return ($type,$udom,$unum,$file_name,$group); 7654: } 7655: return $type; 7656: } 7657: 7658: sub is_portfolio_url { 7659: my ($url) = @_; 7660: return scalar(&parse_portfolio_url($url)); 7661: } 7662: 7663: sub is_portfolio_file { 7664: my ($file) = @_; 7665: if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) { 7666: return 1; 7667: } 7668: return; 7669: } 7670: 7671: sub usertools_access { 7672: my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_; 7673: my ($access,%tools); 7674: if ($context eq '') { 7675: $context = 'tools'; 7676: } 7677: if ($context eq 'requestcourses') { 7678: %tools = ( 7679: official => 1, 7680: unofficial => 1, 7681: community => 1, 7682: textbook => 1, 7683: placement => 1, 7684: lti => 1, 7685: ); 7686: } elsif ($context eq 'requestauthor') { 7687: %tools = ( 7688: requestauthor => 1, 7689: ); 7690: } else { 7691: %tools = ( 7692: aboutme => 1, 7693: blog => 1, 7694: webdav => 1, 7695: portfolio => 1, 7696: ); 7697: } 7698: return if (!defined($tools{$tool})); 7699: 7700: if (($udom eq '') || ($uname eq '')) { 7701: $udom = $env{'user.domain'}; 7702: $uname = $env{'user.name'}; 7703: } 7704: 7705: if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { 7706: if ($action ne 'reload') { 7707: if ($context eq 'requestcourses') { 7708: return $env{'environment.canrequest.'.$tool}; 7709: } elsif ($context eq 'requestauthor') { 7710: return $env{'environment.canrequest.author'}; 7711: } else { 7712: return $env{'environment.availabletools.'.$tool}; 7713: } 7714: } 7715: } 7716: 7717: my ($toolstatus,$inststatus,$envkey); 7718: if ($context eq 'requestauthor') { 7719: $envkey = $context; 7720: } else { 7721: $envkey = $context.'.'.$tool; 7722: } 7723: 7724: if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && 7725: ($action ne 'reload')) { 7726: $toolstatus = $env{'environment.'.$envkey}; 7727: $inststatus = $env{'environment.inststatus'}; 7728: } else { 7729: if (ref($userenvref) eq 'HASH') { 7730: $toolstatus = $userenvref->{$envkey}; 7731: $inststatus = $userenvref->{'inststatus'}; 7732: } else { 7733: my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus'); 7734: $toolstatus = $userenv{$envkey}; 7735: $inststatus = $userenv{'inststatus'}; 7736: } 7737: } 7738: 7739: if ($toolstatus ne '') { 7740: if ($toolstatus) { 7741: $access = 1; 7742: } else { 7743: $access = 0; 7744: } 7745: return $access; 7746: } 7747: 7748: my ($is_adv,%domdef); 7749: if (ref($is_advref) eq 'HASH') { 7750: $is_adv = $is_advref->{'is_adv'}; 7751: } else { 7752: $is_adv = &is_advanced_user($udom,$uname); 7753: } 7754: if (ref($domdefref) eq 'HASH') { 7755: %domdef = %{$domdefref}; 7756: } else { 7757: %domdef = &get_domain_defaults($udom); 7758: } 7759: if (ref($domdef{$tool}) eq 'HASH') { 7760: if ($is_adv) { 7761: if ($domdef{$tool}{'_LC_adv'} ne '') { 7762: if ($domdef{$tool}{'_LC_adv'}) { 7763: $access = 1; 7764: } else { 7765: $access = 0; 7766: } 7767: return $access; 7768: } 7769: } 7770: if ($inststatus ne '') { 7771: my ($hasaccess,$hasnoaccess); 7772: foreach my $affiliation (split(/:/,$inststatus)) { 7773: if ($domdef{$tool}{$affiliation} ne '') { 7774: if ($domdef{$tool}{$affiliation}) { 7775: $hasaccess = 1; 7776: } else { 7777: $hasnoaccess = 1; 7778: } 7779: } 7780: } 7781: if ($hasaccess || $hasnoaccess) { 7782: if ($hasaccess) { 7783: $access = 1; 7784: } elsif ($hasnoaccess) { 7785: $access = 0; 7786: } 7787: return $access; 7788: } 7789: } else { 7790: if ($domdef{$tool}{'default'} ne '') { 7791: if ($domdef{$tool}{'default'}) { 7792: $access = 1; 7793: } elsif ($domdef{$tool}{'default'} == 0) { 7794: $access = 0; 7795: } 7796: return $access; 7797: } 7798: } 7799: } else { 7800: if (($context eq 'tools') && ($tool ne 'webdav')) { 7801: $access = 1; 7802: } else { 7803: $access = 0; 7804: } 7805: return $access; 7806: } 7807: } 7808: 7809: sub is_course_owner { 7810: my ($cdom,$cnum,$udom,$uname) = @_; 7811: if (($udom eq '') || ($uname eq '')) { 7812: $udom = $env{'user.domain'}; 7813: $uname = $env{'user.name'}; 7814: } 7815: unless (($udom eq '') || ($uname eq '')) { 7816: if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) { 7817: if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) { 7818: return 1; 7819: } else { 7820: my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum); 7821: if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) { 7822: return 1; 7823: } 7824: } 7825: } 7826: } 7827: return; 7828: } 7829: 7830: sub is_advanced_user { 7831: my ($udom,$uname) = @_; 7832: if ($udom ne '' && $uname ne '') { 7833: if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { 7834: if (wantarray) { 7835: return ($env{'user.adv'},$env{'user.author'}); 7836: } else { 7837: return $env{'user.adv'}; 7838: } 7839: } 7840: } 7841: my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); 7842: my %allroles; 7843: my ($is_adv,$is_author); 7844: foreach my $role (keys(%roleshash)) { 7845: my ($trest,$tdomain,$trole,$sec) = split(/:/,$role); 7846: my $area = '/'.$tdomain.'/'.$trest; 7847: if ($sec ne '') { 7848: $area .= '/'.$sec; 7849: } 7850: if (($area ne '') && ($trole ne '')) { 7851: my $spec=$trole.'.'.$area; 7852: if ($trole =~ /^cr\//) { 7853: &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); 7854: } elsif ($trole ne 'gr') { 7855: &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); 7856: } 7857: if ($trole eq 'au') { 7858: $is_author = 1; 7859: } 7860: } 7861: } 7862: foreach my $role (keys(%allroles)) { 7863: last if ($is_adv); 7864: foreach my $item (split(/:/,$allroles{$role})) { 7865: if ($item ne '') { 7866: my ($privilege,$restrictions)=split(/&/,$item); 7867: if ($privilege eq 'adv') { 7868: $is_adv = 1; 7869: last; 7870: } 7871: } 7872: } 7873: } 7874: if (wantarray) { 7875: return ($is_adv,$is_author); 7876: } 7877: return $is_adv; 7878: } 7879: 7880: sub check_can_request { 7881: my ($dom,$can_request,$request_domains,$uname,$udom) = @_; 7882: my $canreq = 0; 7883: if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { 7884: $uname = $env{'user.name'}; 7885: $udom = $env{'user.domain'}; 7886: } 7887: my ($types,$typename) = &Apache::loncommon::course_types(); 7888: my @options = ('approval','validate','autolimit'); 7889: my $optregex = join('|',@options); 7890: if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { 7891: foreach my $type (@{$types}) { 7892: if (&usertools_access($uname,$udom,$type,undef, 7893: 'requestcourses')) { 7894: $canreq ++; 7895: if (ref($request_domains) eq 'HASH') { 7896: push(@{$request_domains->{$type}},$udom); 7897: } 7898: if ($dom eq $udom) { 7899: $can_request->{$type} = 1; 7900: } 7901: } 7902: if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') && 7903: ($env{'environment.reqcrsotherdom.'.$type} ne '')) { 7904: my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type}); 7905: if (@curr > 0) { 7906: foreach my $item (@curr) { 7907: if (ref($request_domains) eq 'HASH') { 7908: my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/); 7909: if ($otherdom ne '') { 7910: if (ref($request_domains->{$type}) eq 'ARRAY') { 7911: unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) { 7912: push(@{$request_domains->{$type}},$otherdom); 7913: } 7914: } else { 7915: push(@{$request_domains->{$type}},$otherdom); 7916: } 7917: } 7918: } 7919: } 7920: unless ($dom eq $env{'user.domain'}) { 7921: $canreq ++; 7922: if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) { 7923: $can_request->{$type} = 1; 7924: } 7925: } 7926: } 7927: } 7928: } 7929: } 7930: return $canreq; 7931: } 7932: 7933: # ---------------------------------------------- Custom access rule evaluation 7934: 7935: sub customaccess { 7936: my ($priv,$uri)=@_; 7937: my ($urole,$urealm)=split(/\./,$env{'request.role'},2); 7938: my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm); 7939: $udom = &LONCAPA::clean_domain($udom); 7940: $ucrs = &LONCAPA::clean_username($ucrs); 7941: my $access=0; 7942: foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { 7943: my ($effect,$realm,$role,$type)=split(/\:/,$right); 7944: if ($type eq 'user') { 7945: foreach my $scope (split(/\s*\,\s*/,$realm)) { 7946: my ($tdom,$tuname)=split(m{/},$scope); 7947: if ($tdom) { 7948: if ($tdom ne $env{'user.domain'}) { next; } 7949: } 7950: if ($tuname) { 7951: if ($tuname ne $env{'user.name'}) { next; } 7952: } 7953: $access=($effect eq 'allow'); 7954: last; 7955: } 7956: } else { 7957: if ($role) { 7958: if ($role ne $urole) { next; } 7959: } 7960: foreach my $scope (split(/\s*\,\s*/,$realm)) { 7961: my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); 7962: if ($tdom) { 7963: if ($tdom ne $udom) { next; } 7964: } 7965: if ($tcrs) { 7966: if ($tcrs ne $ucrs) { next; } 7967: } 7968: if ($tsec) { 7969: if ($tsec ne $usec) { next; } 7970: } 7971: $access=($effect eq 'allow'); 7972: last; 7973: } 7974: if ($realm eq '' && $role eq '') { 7975: $access=($effect eq 'allow'); 7976: } 7977: } 7978: } 7979: return $access; 7980: } 7981: 7982: # ------------------------------------------------- Check for a user privilege 7983: 7984: sub allowed { 7985: my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_; 7986: my $ver_orguri=$uri; 7987: $uri=&deversion($uri); 7988: my $orguri=$uri; 7989: $uri=&declutter($uri); 7990: 7991: if ($priv eq 'evb') { 7992: # Evade communication block restrictions for specified role in a course 7993: if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) { 7994: return $1; 7995: } else { 7996: return; 7997: } 7998: } 7999: 8000: if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } 8001: # Free bre access to adm and meta resources 8002: if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) 8003: || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 8004: && ($priv eq 'bre')) { 8005: return 'F'; 8006: } 8007: 8008: # Free bre access to user's own portfolio contents 8009: my ($space,$domain,$name,@dir)=split('/',$uri); 8010: if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 8011: ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { 8012: my %setters; 8013: my ($startblock,$endblock) = 8014: &Apache::loncommon::blockcheck(\%setters,'port'); 8015: if ($startblock && $endblock) { 8016: return 'B'; 8017: } else { 8018: return 'F'; 8019: } 8020: } 8021: 8022: # bre access to group portfolio for rgf priv in group, or mdg or vcg in course. 8023: if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') 8024: && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) { 8025: if (exists($env{'request.course.id'})) { 8026: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 8027: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; 8028: if (($domain eq $cdom) && ($name eq $cnum)) { 8029: my $courseprivid=$env{'request.course.id'}; 8030: $courseprivid=~s/\_/\//; 8031: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid 8032: .'/'.$dir[1]} =~/rgf\&([^\:]*)/) { 8033: return $1; 8034: } else { 8035: if ($env{'request.course.sec'}) { 8036: $courseprivid.='/'.$env{'request.course.sec'}; 8037: } 8038: if ($env{'user.priv.'.$env{'request.role'}.'./'. 8039: $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) { 8040: return $2; 8041: } 8042: } 8043: } 8044: } 8045: } 8046: 8047: # Free bre to public access 8048: 8049: if ($priv eq 'bre') { 8050: my $copyright; 8051: unless ($uri =~ /ext\.tool/) { 8052: $copyright=&metadata($uri,'copyright'); 8053: } 8054: if (($copyright eq 'public') && (!$env{'request.course.id'})) { 8055: return 'F'; 8056: } 8057: if ($copyright eq 'priv') { 8058: $uri=~/([^\/]+)\/([^\/]+)\//; 8059: unless (($env{'user.name'} eq $2) && ($env{'user.domain'} eq $1)) { 8060: return ''; 8061: } 8062: } 8063: if ($copyright eq 'domain') { 8064: $uri=~/([^\/]+)\/([^\/]+)\//; 8065: unless (($env{'user.domain'} eq $1) || 8066: ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $1)) { 8067: return ''; 8068: } 8069: } 8070: if ($env{'request.role'}=~ /li\.\//) { 8071: # Library role, so allow browsing of resources in this domain. 8072: return 'F'; 8073: } 8074: if ($copyright eq 'custom') { 8075: unless (&customaccess($priv,$uri)) { return ''; } 8076: } 8077: } 8078: # Domain coordinator is trying to create a course 8079: if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) { 8080: # uri is the requested domain in this case. 8081: # comparison to 'request.role.domain' shows if the user has selected 8082: # a role of dc for the domain in question. 8083: return 'F' if ($uri eq $env{'request.role.domain'}); 8084: } 8085: 8086: my $thisallowed=''; 8087: my $statecond=0; 8088: my $courseprivid=''; 8089: 8090: my $ownaccess; 8091: # Community Coordinator or Assistant Co-author browsing resource space. 8092: if (($priv eq 'bro') && ($env{'user.author'})) { 8093: if ($uri eq '') { 8094: $ownaccess = 1; 8095: } else { 8096: if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { 8097: my $udom = $env{'user.domain'}; 8098: my $uname = $env{'user.name'}; 8099: if ($uri =~ m{^\Q$udom\E/?$}) { 8100: $ownaccess = 1; 8101: } elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) { 8102: unless ($uri =~ m{\.\./}) { 8103: $ownaccess = 1; 8104: } 8105: } elsif (($udom ne 'public') && ($uname ne 'public')) { 8106: my $now = time; 8107: if ($uri =~ m{^([^/]+)/?$}) { 8108: my $adom = $1; 8109: foreach my $key (keys(%env)) { 8110: if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) { 8111: my ($start,$end) = split('.',$env{$key}); 8112: if (($now >= $start) && (!$end || $end < $now)) { 8113: $ownaccess = 1; 8114: last; 8115: } 8116: } 8117: } 8118: } elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) { 8119: my $adom = $1; 8120: my $aname = $2; 8121: foreach my $role ('ca','aa') { 8122: if ($env{"user.role.$role./$adom/$aname"}) { 8123: my ($start,$end) = 8124: split('.',$env{"user.role.$role./$adom/$aname"}); 8125: if (($now >= $start) && (!$end || $end < $now)) { 8126: $ownaccess = 1; 8127: last; 8128: } 8129: } 8130: } 8131: } 8132: } 8133: } 8134: } 8135: } 8136: 8137: # Course 8138: 8139: if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { 8140: unless (($priv eq 'bro') && (!$ownaccess)) { 8141: $thisallowed.=$1; 8142: } 8143: } 8144: 8145: # Domain 8146: 8147: if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} 8148: =~/\Q$priv\E\&([^\:]*)/) { 8149: unless (($priv eq 'bro') && (!$ownaccess)) { 8150: $thisallowed.=$1; 8151: } 8152: } 8153: 8154: # User who is not author or co-author might still be able to edit 8155: # resource of an author in the domain (e.g., if Domain Coordinator). 8156: if (($priv eq 'eco') && ($thisallowed eq '') && ($env{'request.course.id'}) && 8157: (&allowed('mdc',$env{'request.course.id'}))) { 8158: if ($env{"user.priv.cm./$uri/"}=~/\Q$priv\E\&([^\:]*)/) { 8159: $thisallowed.=$1; 8160: } 8161: } 8162: 8163: # Course: uri itself is a course 8164: my $courseuri=$uri; 8165: $courseuri=~s/\_(\d)/\/$1/; 8166: $courseuri=~s/^([^\/])/\/$1/; 8167: 8168: if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} 8169: =~/\Q$priv\E\&([^\:]*)/) { 8170: if ($priv eq 'mip') { 8171: my $rem = $1; 8172: if (($uri ne '') && ($env{'request.course.id'} eq $uri) && 8173: ($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) { 8174: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 8175: if ($cdom ne '') { 8176: my %passwdconf = &get_passwdconf($cdom); 8177: if (ref($passwdconf{'crsownerchg'}) eq 'HASH') { 8178: if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') { 8179: if (@{$passwdconf{'crsownerchg'}{'by'}}) { 8180: my @inststatuses = split(':',$env{'environment.inststatus'}); 8181: unless (@inststatuses) { 8182: @inststatuses = ('default'); 8183: } 8184: foreach my $status (@inststatuses) { 8185: if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) { 8186: $thisallowed.=$rem; 8187: } 8188: } 8189: } 8190: } 8191: } 8192: } 8193: } 8194: } else { 8195: unless (($priv eq 'bro') && (!$ownaccess)) { 8196: $thisallowed.=$1; 8197: } 8198: } 8199: } 8200: 8201: # URI is an uploaded document for this course, default permissions don't matter 8202: # not allowing 'edit' access (editupload) to uploaded course docs 8203: if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { 8204: $thisallowed=''; 8205: my ($match)=&is_on_map($uri); 8206: if ($match) { 8207: if ($env{'user.priv.'.$env{'request.role'}.'./'} 8208: =~/\Q$priv\E\&([^\:]*)/) { 8209: my $value = $1; 8210: my $deeplinkblock = &deeplink_check($priv,$symb,$uri); 8211: if ($deeplinkblock) { 8212: $thisallowed='D'; 8213: } elsif ($noblockcheck) { 8214: $thisallowed.=$value; 8215: } else { 8216: my @blockers = &has_comm_blocking($priv,$symb,$uri); 8217: if (@blockers > 0) { 8218: $thisallowed = 'B'; 8219: } else { 8220: $thisallowed.=$value; 8221: } 8222: } 8223: } 8224: } else { 8225: my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri}; 8226: if ($refuri) { 8227: if ($refuri =~ m|^/adm/|) { 8228: $thisallowed='F'; 8229: } else { 8230: $refuri=&declutter($refuri); 8231: my ($match) = &is_on_map($refuri); 8232: if ($match) { 8233: my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); 8234: if ($deeplinkblock) { 8235: $thisallowed='D'; 8236: } elsif ($noblockcheck) { 8237: $thisallowed='F'; 8238: } else { 8239: my @blockers = &has_comm_blocking($priv,$symb,$refuri); 8240: if (@blockers > 0) { 8241: $thisallowed = 'B'; 8242: } else { 8243: $thisallowed='F'; 8244: } 8245: } 8246: } 8247: } 8248: } 8249: } 8250: } 8251: 8252: if ($priv eq 'bre' 8253: && $thisallowed ne 'F' 8254: && $thisallowed ne '2' 8255: && &is_portfolio_url($uri)) { 8256: $thisallowed = &portfolio_access($uri,$clientip); 8257: } 8258: 8259: # Full access at system, domain or course-wide level? Exit. 8260: if ($thisallowed=~/F/) { 8261: return 'F'; 8262: } 8263: 8264: # If this is generating or modifying users, exit with special codes 8265: 8266: if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) { 8267: if (($priv eq 'cca') || ($priv eq 'caa')) { 8268: my ($audom,$auname)=split('/',$uri); 8269: # no author name given, so this just checks on the general right to make a co-author in this domain 8270: unless ($auname) { return $thisallowed; } 8271: # an author name is given, so we are about to actually make a co-author for a certain account 8272: if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) || 8273: (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) && 8274: ($audom ne $env{'request.role.domain'}))) { return ''; } 8275: } 8276: return $thisallowed; 8277: } 8278: # 8279: # Gathered so far: system, domain and course wide privileges 8280: # 8281: # Course: See if uri or referer is an individual resource that is part of 8282: # the course 8283: 8284: if ($env{'request.course.id'}) { 8285: 8286: # If this is modifying password (internal auth) domains must match for user and user's role. 8287: 8288: if ($priv eq 'mip') { 8289: if ($env{'user.domain'} eq $env{'request.role.domain'}) { 8290: return $thisallowed; 8291: } else { 8292: return ''; 8293: } 8294: } 8295: 8296: $courseprivid=$env{'request.course.id'}; 8297: if ($env{'request.course.sec'}) { 8298: $courseprivid.='/'.$env{'request.course.sec'}; 8299: } 8300: $courseprivid=~s/\_/\//; 8301: my $checkreferer=1; 8302: my ($match,$cond)=&is_on_map($uri); 8303: if ($match) { 8304: $statecond=$cond; 8305: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} 8306: =~/\Q$priv\E\&([^\:]*)/) { 8307: my $value = $1; 8308: if ($priv eq 'bre') { 8309: if ($noblockcheck) { 8310: $thisallowed.=$value; 8311: } else { 8312: my @blockers = &has_comm_blocking($priv,$symb,$uri); 8313: if (@blockers > 0) { 8314: $thisallowed = 'B'; 8315: } else { 8316: $thisallowed.=$value; 8317: } 8318: } 8319: } else { 8320: $thisallowed.=$value; 8321: } 8322: $checkreferer=0; 8323: } 8324: } 8325: 8326: if ($checkreferer) { 8327: my $refuri=$env{'httpref.'.$orguri}; 8328: unless ($refuri) { 8329: foreach my $key (keys(%env)) { 8330: if ($key=~/^httpref\..*\*/) { 8331: my $pattern=$key; 8332: $pattern=~s/^httpref\.\/res\///; 8333: $pattern=~s/\*/\[\^\/\]\+/g; 8334: $pattern=~s/\//\\\//g; 8335: if ($orguri=~/$pattern/) { 8336: $refuri=$env{$key}; 8337: } 8338: } 8339: } 8340: } 8341: 8342: if ($refuri) { 8343: $refuri=&declutter($refuri); 8344: my ($match,$cond)=&is_on_map($refuri); 8345: if ($match) { 8346: my $refstatecond=$cond; 8347: if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} 8348: =~/\Q$priv\E\&([^\:]*)/) { 8349: my $value = $1; 8350: if ($priv eq 'bre') { 8351: my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); 8352: if ($deeplinkblock) { 8353: $thisallowed = 'D'; 8354: } elsif ($noblockcheck) { 8355: $thisallowed.=$value; 8356: } else { 8357: my @blockers = &has_comm_blocking($priv,$symb,$refuri); 8358: if (@blockers > 0) { 8359: $thisallowed = 'B'; 8360: } else { 8361: $thisallowed.=$value; 8362: } 8363: } 8364: } else { 8365: $thisallowed.=$value; 8366: } 8367: $uri=$refuri; 8368: $statecond=$refstatecond; 8369: } 8370: } 8371: } 8372: } 8373: } 8374: 8375: # 8376: # Gathered now: all privileges that could apply, and condition number 8377: # 8378: # 8379: # Full or no access? 8380: # 8381: 8382: if ($thisallowed=~/F/) { 8383: return 'F'; 8384: } 8385: 8386: unless ($thisallowed) { 8387: return ''; 8388: } 8389: 8390: # Restrictions exist, deal with them 8391: # 8392: # C:according to course preferences 8393: # R:according to resource settings 8394: # L:unless locked 8395: # X:according to user session state 8396: # 8397: 8398: # Possibly locked functionality, check all courses 8399: # Locks might take effect only after 10 minutes cache expiration for other 8400: # courses, and 2 minutes for current course 8401: 8402: my $envkey; 8403: if ($thisallowed=~/L/) { 8404: foreach $envkey (keys(%env)) { 8405: if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { 8406: my $courseid=$2; 8407: my $roleid=$1.'.'.$2; 8408: $courseid=~s/^\///; 8409: my $expiretime=600; 8410: if ($env{'request.role'} eq $roleid) { 8411: $expiretime=120; 8412: } 8413: my ($cdom,$cnum,$csec)=split(/\//,$courseid); 8414: my $prefix='course.'.$cdom.'_'.$cnum.'.'; 8415: if ((time-$env{$prefix.'last_cache'})>$expiretime) { 8416: &coursedescription($courseid,{'freshen_cache' => 1}); 8417: } 8418: if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/) 8419: || ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { 8420: if ($env{$prefix.'res.'.$uri.'.lock.expire'}>time) { 8421: &log($env{'user.domain'},$env{'user.name'}, 8422: $env{'user.home'}, 8423: 'Locked by res: '.$priv.' for '.$uri.' due to '. 8424: $cdom.'/'.$cnum.'/'.$csec.' expire '. 8425: $env{$prefix.'priv.'.$priv.'.lock.expire'}); 8426: return ''; 8427: } 8428: } 8429: if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) 8430: || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { 8431: if ($env{'priv.'.$priv.'.lock.expire'}>time) { 8432: &log($env{'user.domain'},$env{'user.name'}, 8433: $env{'user.home'}, 8434: 'Locked by priv: '.$priv.' for '.$uri.' due to '. 8435: $cdom.'/'.$cnum.'/'.$csec.' expire '. 8436: $env{$prefix.'priv.'.$priv.'.lock.expire'}); 8437: return ''; 8438: } 8439: } 8440: } 8441: } 8442: } 8443: 8444: # 8445: # Rest of the restrictions depend on selected course 8446: # 8447: 8448: unless ($env{'request.course.id'}) { 8449: if ($thisallowed eq 'A') { 8450: return 'A'; 8451: } elsif ($thisallowed eq 'B') { 8452: return 'B'; 8453: } else { 8454: return '1'; 8455: } 8456: } 8457: 8458: # 8459: # Now user is definitely in a course 8460: # 8461: 8462: 8463: # Course preferences 8464: 8465: if ($thisallowed=~/C/) { 8466: my $rolecode=(split(/\./,$env{'request.role'}))[0]; 8467: my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; 8468: if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} 8469: =~/\Q$rolecode\E/) { 8470: if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) { 8471: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. 8472: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. 8473: $env{'request.course.id'}); 8474: } 8475: return ''; 8476: } 8477: 8478: if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} 8479: =~/\Q$unamedom\E/) { 8480: if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) { 8481: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. 8482: 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. 8483: $env{'request.course.id'}); 8484: } 8485: return ''; 8486: } 8487: } 8488: 8489: # Resource preferences 8490: 8491: if ($thisallowed=~/R/) { 8492: my $rolecode=(split(/\./,$env{'request.role'}))[0]; 8493: if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { 8494: if (($priv ne 'pch') && ($priv ne 'plc')) { 8495: &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. 8496: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); 8497: } 8498: return ''; 8499: } 8500: } 8501: 8502: # Restricted by state or randomout? 8503: 8504: if ($thisallowed=~/X/) { 8505: if ($env{'acc.randomout'}) { 8506: if (!$symb) { $symb=&symbread($uri,1); } 8507: if (($symb) && ($env{'acc.randomout'}=~/\&\Q$symb\E\&/)) { 8508: return ''; 8509: } 8510: } 8511: if (&condval($statecond)) { 8512: return '2'; 8513: } else { 8514: return ''; 8515: } 8516: } 8517: 8518: if ($thisallowed eq 'A') { 8519: return 'A'; 8520: } elsif ($thisallowed eq 'B') { 8521: return 'B'; 8522: } elsif ($thisallowed eq 'D') { 8523: return 'D'; 8524: } 8525: return 'F'; 8526: } 8527: 8528: # ------------------------------------------- Check construction space access 8529: 8530: sub constructaccess { 8531: my ($url,$setpriv)=@_; 8532: 8533: # We do not allow editing of previous versions of files 8534: if ($url=~/\.(\d+)\.(\w+)$/) { return ''; } 8535: 8536: # Get username and domain from URL 8537: my ($ownername,$ownerdomain,$ownerhome); 8538: 8539: ($ownerdomain,$ownername) = 8540: ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)(?:/|$)}); 8541: 8542: # The URL does not really point to any authorspace, forget it 8543: unless (($ownername) && ($ownerdomain)) { return ''; } 8544: 8545: # Now we need to see if the user has access to the authorspace of 8546: # $ownername at $ownerdomain 8547: 8548: if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) { 8549: # Real author for this? 8550: $ownerhome = $env{'user.home'}; 8551: if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) { 8552: return ($ownername,$ownerdomain,$ownerhome); 8553: } 8554: } else { 8555: # Co-author for this? 8556: if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) || 8557: exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) { 8558: $ownerhome = &homeserver($ownername,$ownerdomain); 8559: return ($ownername,$ownerdomain,$ownerhome); 8560: } 8561: if ($env{'request.course.id'}) { 8562: if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) && 8563: ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) { 8564: if (&allowed('mdc',$env{'request.course.id'})) { 8565: $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'}; 8566: return ($ownername,$ownerdomain,$ownerhome); 8567: } 8568: } 8569: } 8570: } 8571: 8572: # We don't have any access right now. If we are not possibly going to do anything about this, 8573: # we might as well leave 8574: unless ($setpriv) { return ''; } 8575: 8576: # Backdoor access? 8577: my $allowed=&allowed('eco',$ownerdomain); 8578: # Nope 8579: unless ($allowed) { return ''; } 8580: # Looks like we may have access, but could be locked by the owner of the construction space 8581: if ($allowed eq 'U') { 8582: my %blocked=&get('environment',['domcoord.author'], 8583: $ownerdomain,$ownername); 8584: # Is blocked by owner 8585: if ($blocked{'domcoord.author'} eq 'blocked') { return ''; } 8586: } 8587: if (($allowed eq 'F') || ($allowed eq 'U')) { 8588: # Grant temporary access 8589: my $then=$env{'user.login.time'}; 8590: my $update=$env{'user.update.time'}; 8591: if (!$update) { $update = $then; } 8592: my $refresh=$env{'user.refresh.time'}; 8593: if (!$refresh) { $refresh = $update; } 8594: my $now = time; 8595: &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh, 8596: $now,'ca','constructaccess'); 8597: $ownerhome = &homeserver($ownername,$ownerdomain); 8598: return($ownername,$ownerdomain,$ownerhome); 8599: } 8600: # No business here 8601: return ''; 8602: } 8603: 8604: # ----------------------------------------------------------- Content Blocking 8605: 8606: { 8607: # Caches for faster Course Contents display where content blocking 8608: # is in operation (i.e., interval param set) for timed quiz. 8609: # 8610: # User for whom data are being temporarily cached. 8611: my $cacheduser=''; 8612: # Cached blockers for this user (a hash of blocking items). 8613: my %cachedblockers=(); 8614: # When the data were last cached. 8615: my $cachedlast=''; 8616: 8617: sub load_all_blockers { 8618: my ($uname,$udom,$blocks)=@_; 8619: if (($uname ne '') && ($udom ne '')) { 8620: if (($cacheduser eq $uname.':'.$udom) && 8621: (abs($cachedlast-time)<5)) { 8622: return; 8623: } 8624: } 8625: $cachedlast=time; 8626: $cacheduser=$uname.':'.$udom; 8627: %cachedblockers = &get_commblock_resources($blocks); 8628: } 8629: 8630: sub get_comm_blocks { 8631: my ($cdom,$cnum) = @_; 8632: if ($cdom eq '' || $cnum eq '') { 8633: return unless ($env{'request.course.id'}); 8634: $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; 8635: $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 8636: } 8637: my %commblocks; 8638: my $hashid=$cdom.'_'.$cnum; 8639: my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid); 8640: if ((defined($cached)) && (ref($blocksref) eq 'HASH')) { 8641: %commblocks = %{$blocksref}; 8642: } else { 8643: %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum); 8644: my $cachetime = 600; 8645: &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime); 8646: } 8647: return %commblocks; 8648: } 8649: 8650: sub get_commblock_resources { 8651: my ($blocks) = @_; 8652: my %blockers = (); 8653: return %blockers unless ($env{'request.course.id'}); 8654: return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); 8655: my %commblocks; 8656: if (ref($blocks) eq 'HASH') { 8657: %commblocks = %{$blocks}; 8658: } else { 8659: %commblocks = &get_comm_blocks(); 8660: } 8661: return %blockers unless (keys(%commblocks) > 0); 8662: my $navmap = Apache::lonnavmaps::navmap->new(); 8663: return %blockers unless (ref($navmap)); 8664: my $now = time; 8665: foreach my $block (keys(%commblocks)) { 8666: if ($block =~ /^(\d+)____(\d+)$/) { 8667: my ($start,$end) = ($1,$2); 8668: if ($start <= $now && $end >= $now) { 8669: if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { 8670: if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { 8671: if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { 8672: if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { 8673: $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; 8674: } 8675: } 8676: if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { 8677: if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { 8678: $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; 8679: } 8680: } 8681: } 8682: } 8683: } 8684: } elsif ($block =~ /^firstaccess____(.+)$/) { 8685: my $item = $1; 8686: my @to_test; 8687: if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { 8688: if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { 8689: my @interval; 8690: my $type = 'map'; 8691: if ($item eq 'course') { 8692: $type = 'course'; 8693: @interval=&EXT("resource.0.interval"); 8694: } else { 8695: if ($item =~ /___\d+___/) { 8696: $type = 'resource'; 8697: @interval=&EXT("resource.0.interval",$item); 8698: if (ref($navmap)) { 8699: my $res = $navmap->getBySymb($item); 8700: push(@to_test,$res); 8701: } 8702: } else { 8703: my $mapsymb = &symbread($item,1); 8704: if ($mapsymb) { 8705: if (ref($navmap)) { 8706: my $mapres = $navmap->getBySymb($mapsymb); 8707: @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1); 8708: foreach my $res (@to_test) { 8709: my $symb = $res->symb(); 8710: next if ($symb eq $mapsymb); 8711: if ($symb ne '') { 8712: @interval=&EXT("resource.0.interval",$symb); 8713: if ($interval[1] eq 'map') { 8714: last; 8715: } 8716: } 8717: } 8718: } 8719: } 8720: } 8721: } 8722: if ($interval[0] =~ /^(\d+)/) { 8723: my $timelimit = $1; 8724: my $first_access; 8725: if ($type eq 'resource') { 8726: $first_access=&get_first_access($interval[1],$item); 8727: } elsif ($type eq 'map') { 8728: $first_access=&get_first_access($interval[1],undef,$item); 8729: } else { 8730: $first_access=&get_first_access($interval[1]); 8731: } 8732: if ($first_access) { 8733: my $timesup = $first_access+$timelimit; 8734: if ($timesup > $now) { 8735: my $activeblock; 8736: foreach my $res (@to_test) { 8737: if ($res->answerable()) { 8738: $activeblock = 1; 8739: last; 8740: } 8741: } 8742: if ($activeblock) { 8743: if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { 8744: if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { 8745: $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; 8746: } 8747: } 8748: if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { 8749: if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { 8750: $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; 8751: } 8752: } 8753: } 8754: } 8755: } 8756: } 8757: } 8758: } 8759: } 8760: } 8761: return %blockers; 8762: } 8763: 8764: sub has_comm_blocking { 8765: my ($priv,$symb,$uri,$blocks) = @_; 8766: my @blockers; 8767: return unless ($env{'request.course.id'}); 8768: return unless ($priv eq 'bre'); 8769: return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); 8770: return if ($env{'request.state'} eq 'construct'); 8771: &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks); 8772: return unless (keys(%cachedblockers) > 0); 8773: my (%possibles,@symbs); 8774: if (!$symb) { 8775: $symb = &symbread($uri,1,1,1,\%possibles); 8776: } 8777: if ($symb) { 8778: @symbs = ($symb); 8779: } elsif (keys(%possibles)) { 8780: @symbs = keys(%possibles); 8781: } 8782: my $noblock; 8783: foreach my $symb (@symbs) { 8784: last if ($noblock); 8785: my ($map,$resid,$resurl)=&decode_symb($symb); 8786: foreach my $block (keys(%cachedblockers)) { 8787: if ($block =~ /^firstaccess____(.+)$/) { 8788: my $item = $1; 8789: if (($item eq $map) || ($item eq $symb)) { 8790: $noblock = 1; 8791: last; 8792: } 8793: } 8794: if (ref($cachedblockers{$block}) eq 'HASH') { 8795: if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') { 8796: if ($cachedblockers{$block}{'resources'}{$symb}) { 8797: unless (grep(/^\Q$block\E$/,@blockers)) { 8798: push(@blockers,$block); 8799: } 8800: } 8801: } 8802: } 8803: if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') { 8804: if ($cachedblockers{$block}{'maps'}{$map}) { 8805: unless (grep(/^\Q$block\E$/,@blockers)) { 8806: push(@blockers,$block); 8807: } 8808: } 8809: } 8810: } 8811: } 8812: return if ($noblock); 8813: return @blockers; 8814: } 8815: } 8816: 8817: sub deeplink_check { 8818: my ($priv,$symb,$uri) = @_; 8819: return unless ($env{'request.course.id'}); 8820: return unless ($priv eq 'bre'); 8821: return if ($env{'request.state'} eq 'construct'); 8822: return if ($env{'request.role.adv'}); 8823: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 8824: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; 8825: my (%possibles,@symbs); 8826: if (!$symb) { 8827: $symb = &symbread($uri,1,1,1,\%possibles); 8828: } 8829: if ($symb) { 8830: @symbs = ($symb); 8831: } elsif (keys(%possibles)) { 8832: @symbs = keys(%possibles); 8833: } 8834: 8835: my ($login,$switchrole,$allow); 8836: if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) { 8837: my $key = $1; 8838: my $tinyurl; 8839: my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key); 8840: if (defined($cached)) { 8841: $tinyurl = $result; 8842: } else { 8843: my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); 8844: my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname); 8845: if ($currtiny{$key} ne '') { 8846: $tinyurl = $currtiny{$key}; 8847: &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600); 8848: } 8849: } 8850: if ($tinyurl ne '') { 8851: my ($cnumreq,$posslogin) = split(/\&/,$tinyurl); 8852: if ($cnumreq eq $cnum) { 8853: $login = $posslogin; 8854: } else { 8855: $switchrole = 1; 8856: } 8857: } 8858: } 8859: foreach my $symb (@symbs) { 8860: last if ($allow); 8861: my $deeplink = &EXT("resource.0.deeplink",$symb); 8862: if ($deeplink eq '') { 8863: $allow = 1; 8864: } else { 8865: my ($listed,$scope,$access) = split(/,/,$deeplink); 8866: if ($access eq 'any') { 8867: $allow = 1; 8868: } elsif ($login) { 8869: if ($access eq 'only') { 8870: if ($scope eq 'res') { 8871: if ($symb eq $login) { 8872: $allow = 1; 8873: } 8874: } elsif ($scope eq 'map') { 8875: #FIXME Compare map for $env{'request.deeplink.login'} with map for $symb 8876: } elsif ($scope eq 'rec') { 8877: #FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb 8878: } 8879: } else { 8880: my ($acctype,$item) = split(/:/,$access); 8881: if (($acctype eq 'lti') && ($env{'user.linkprotector'})) { 8882: if (grep(/^\Q$item\E$/,split(/,/,$env{'user.linkprotector'}))) { 8883: my %tinyurls = &get('tiny',[$symb],$cdom,$cnum); 8884: if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.linkproturis'}))) { 8885: $allow = 1; 8886: } 8887: } 8888: } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) { 8889: if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) { 8890: my %tinyurls = &get('tiny',[$symb],$cdom,$cnum); 8891: if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) { 8892: $allow = 1; 8893: } 8894: } 8895: } 8896: } 8897: } 8898: } 8899: } 8900: return if ($allow); 8901: return 1; 8902: } 8903: 8904: # -------------------------------- Deversion and split uri into path an filename 8905: 8906: # 8907: # Removes the version from a URI and 8908: # splits it in to its filename and path to the filename. 8909: # Seems like File::Basename could have done this more clearly. 8910: # Parameters: 8911: # $uri - input URI 8912: # Returns: 8913: # Two element list consisting of 8914: # $pathname - the URI up to and excluding the trailing / 8915: # $filename - The part of the URI following the last / 8916: # NOTE: 8917: # Another realization of this is simply: 8918: # use File::Basename; 8919: # ... 8920: # $uri = shift; 8921: # $filename = basename($uri); 8922: # $path = dirname($uri); 8923: # return ($filename, $path); 8924: # 8925: # The implementation below is probably faster however. 8926: # 8927: sub split_uri_for_cond { 8928: my $uri=&deversion(&declutter(shift)); 8929: my @uriparts=split(/\//,$uri); 8930: my $filename=pop(@uriparts); 8931: my $pathname=join('/',@uriparts); 8932: return ($pathname,$filename); 8933: } 8934: # --------------------------------------------------- Is a resource on the map? 8935: 8936: sub is_on_map { 8937: my ($pathname,$filename) = &split_uri_for_cond(shift); 8938: #Trying to find the conditional for the file 8939: my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~ 8940: /\&\Q$filename\E\:([\d\|]+)\&/); 8941: if ($match) { 8942: return (1,$1); 8943: } else { 8944: return (0,0); 8945: } 8946: } 8947: 8948: # --------------------------------------------------------- Get symb from alias 8949: 8950: sub get_symb_from_alias { 8951: my $symb=shift; 8952: my ($map,$resid,$url)=&decode_symb($symb); 8953: # Already is a symb 8954: if ($url) { return $symb; } 8955: # Must be an alias 8956: my $aliassymb=''; 8957: my %bighash; 8958: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', 8959: &GDBM_READER(),0640)) { 8960: my $rid=$bighash{'mapalias_'.$symb}; 8961: if ($rid) { 8962: my ($mapid,$resid)=split(/\./,$rid); 8963: $aliassymb=&encode_symb($bighash{'map_id_'.$mapid}, 8964: $resid,$bighash{'src_'.$rid}); 8965: } 8966: untie %bighash; 8967: } 8968: return $aliassymb; 8969: } 8970: 8971: # ----------------------------------------------------------------- Define Role 8972: 8973: sub definerole { 8974: if (allowed('mcr','/')) { 8975: my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_; 8976: foreach my $role (split(':',$sysrole)) { 8977: my ($crole,$cqual)=split(/\&/,$role); 8978: if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } 8979: if ($pr{'cr:s'}=~/\Q$crole\E\&/) { 8980: if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 8981: return "refused:s:$crole&$cqual"; 8982: } 8983: } 8984: } 8985: foreach my $role (split(':',$domrole)) { 8986: my ($crole,$cqual)=split(/\&/,$role); 8987: if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } 8988: if ($pr{'cr:d'}=~/\Q$crole\E\&/) { 8989: if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { 8990: return "refused:d:$crole&$cqual"; 8991: } 8992: } 8993: } 8994: foreach my $role (split(':',$courole)) { 8995: my ($crole,$cqual)=split(/\&/,$role); 8996: if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } 8997: if ($pr{'cr:c'}=~/\Q$crole\E\&/) { 8998: if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { 8999: return "refused:c:$crole&$cqual"; 9000: } 9001: } 9002: } 9003: my $uhome; 9004: if (($uname ne '') && ($udom ne '')) { 9005: $uhome = &homeserver($uname,$udom); 9006: return $uhome if ($uhome eq 'no_host'); 9007: } else { 9008: $uname = $env{'user.name'}; 9009: $udom = $env{'user.domain'}; 9010: $uhome = $env{'user.home'}; 9011: } 9012: my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". 9013: "$udom:$uname:rolesdef_$rolename=". 9014: escape($sysrole.'_'.$domrole.'_'.$courole); 9015: return reply($command,$uhome); 9016: } else { 9017: return 'refused'; 9018: } 9019: } 9020: 9021: # ---------------- Make a metadata query against the network of library servers 9022: 9023: sub metadata_query { 9024: my ($query,$custom,$customshow,$server_array,$domains_hash)=@_; 9025: my %rhash; 9026: my %libserv = &all_library(); 9027: my @server_list = (defined($server_array) ? @$server_array 9028: : keys(%libserv) ); 9029: for my $server (@server_list) { 9030: my $domains = ''; 9031: if (ref($domains_hash) eq 'HASH') { 9032: $domains = $domains_hash->{$server}; 9033: } 9034: unless ($custom or $customshow) { 9035: my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server); 9036: $rhash{$server}=$reply; 9037: } 9038: else { 9039: my $reply=&reply("querysend:".&escape($query).':'. 9040: &escape($custom).':'.&escape($customshow).':'.&escape($domains), 9041: $server); 9042: $rhash{$server}=$reply; 9043: } 9044: } 9045: return \%rhash; 9046: } 9047: 9048: # ----------------------------------------- Send log queries and wait for reply 9049: 9050: sub log_query { 9051: my ($uname,$udom,$query,%filters)=@_; 9052: my $uhome=&homeserver($uname,$udom); 9053: if ($uhome eq 'no_host') { return 'error: no_host'; } 9054: my $uhost=&hostname($uhome); 9055: my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); 9056: my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, 9057: $uhome); 9058: unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } 9059: return get_query_reply($queryid); 9060: } 9061: 9062: # -------------------------- Update MySQL table for portfolio file 9063: 9064: sub update_portfolio_table { 9065: my ($uname,$udom,$file_name,$query,$group,$action) = @_; 9066: if ($group ne '') { 9067: $file_name =~s /^\Q$group\E//; 9068: } 9069: my $homeserver = &homeserver($uname,$udom); 9070: my $queryid= 9071: &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). 9072: ':'.&escape($file_name).':'.$action,$homeserver); 9073: my $reply = &get_query_reply($queryid); 9074: return $reply; 9075: } 9076: 9077: # -------------------------- Update MySQL allusers table 9078: 9079: sub update_allusers_table { 9080: my ($uname,$udom,$names) = @_; 9081: my $homeserver = &homeserver($uname,$udom); 9082: my $queryid= 9083: &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'. 9084: 'lastname='.&escape($names->{'lastname'}).'%%'. 9085: 'firstname='.&escape($names->{'firstname'}).'%%'. 9086: 'middlename='.&escape($names->{'middlename'}).'%%'. 9087: 'generation='.&escape($names->{'generation'}).'%%'. 9088: 'permanentemail='.&escape($names->{'permanentemail'}).'%%'. 9089: 'id='.&escape($names->{'id'}),$homeserver); 9090: return; 9091: } 9092: 9093: # ------- Request retrieval of institutional classlists for course(s) 9094: 9095: sub fetch_enrollment_query { 9096: my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; 9097: my ($homeserver,$sleep,$loopmax); 9098: my $maxtries = 1; 9099: if ($context eq 'automated') { 9100: $homeserver = $perlvar{'lonHostID'}; 9101: $sleep = 2; 9102: $loopmax = 100; 9103: $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout 9104: } else { 9105: $homeserver = &homeserver($cnum,$dom); 9106: } 9107: my $host=&hostname($homeserver); 9108: my $cmd = ''; 9109: foreach my $affiliate (keys(%{$affiliatesref})) { 9110: $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; 9111: } 9112: $cmd =~ s/%%$//; 9113: $cmd = &escape($cmd); 9114: my $query = 'fetchenrollment'; 9115: my $queryid=&reply("querysend:".$query.':'.$dom.':'.$env{'user.name'}.':'.$cmd,$homeserver); 9116: unless ($queryid=~/^\Q$host\E\_/) { 9117: &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 9118: return 'error: '.$queryid; 9119: } 9120: my $reply = &get_query_reply($queryid,$sleep,$loopmax); 9121: my $tries = 1; 9122: while (($reply=~/^timeout/) && ($tries < $maxtries)) { 9123: $reply = &get_query_reply($queryid,$sleep,$loopmax); 9124: $tries ++; 9125: } 9126: if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { 9127: &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); 9128: } else { 9129: my @responses = split(/:/,$reply); 9130: if (grep { $_ eq $homeserver } &current_machine_ids()) { 9131: foreach my $line (@responses) { 9132: my ($key,$value) = split(/=/,$line,2); 9133: $$replyref{$key} = $value; 9134: } 9135: } else { 9136: my $pathname = LONCAPA::tempdir(); 9137: foreach my $line (@responses) { 9138: my ($key,$value) = split(/=/,$line); 9139: $$replyref{$key} = $value; 9140: if ($value > 0) { 9141: foreach my $item (@{$$affiliatesref{$key}}) { 9142: my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml'; 9143: my $destname = $pathname.'/'.$filename; 9144: my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); 9145: if ($xml_classlist =~ /^error/) { 9146: &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); 9147: } else { 9148: if ( open(FILE,">",$destname) ) { 9149: print FILE &unescape($xml_classlist); 9150: close(FILE); 9151: } else { 9152: &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); 9153: } 9154: } 9155: } 9156: } 9157: } 9158: } 9159: return 'ok'; 9160: } 9161: return 'error'; 9162: } 9163: 9164: sub get_query_reply { 9165: my ($queryid,$sleep,$loopmax) = @_;; 9166: if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) { 9167: $sleep = 0.2; 9168: } 9169: if (($loopmax eq '') || ($loopmax =~ /\D/)) { 9170: $loopmax = 100; 9171: } 9172: my $replyfile=LONCAPA::tempdir().$queryid; 9173: my $reply=''; 9174: for (1..$loopmax) { 9175: sleep($sleep); 9176: if (-e $replyfile.'.end') { 9177: if (open(my $fh,"<",$replyfile)) { 9178: $reply = join('',<$fh>); 9179: close($fh); 9180: } else { return 'error: reply_file_error'; } 9181: return &unescape($reply); 9182: } 9183: } 9184: return 'timeout:'.$queryid; 9185: } 9186: 9187: sub courselog_query { 9188: # 9189: # possible filters: 9190: # url: url or symb 9191: # username 9192: # domain 9193: # action: view, submit, grade 9194: # start: timestamp 9195: # end: timestamp 9196: # 9197: my (%filters)=@_; 9198: unless ($env{'request.course.id'}) { return 'no_course'; } 9199: if ($filters{'url'}) { 9200: $filters{'url'}=&symbclean(&declutter($filters{'url'})); 9201: $filters{'url'}=~s/\.(\w+)$/(\\.\\d+)*\\.$1/; 9202: $filters{'url'}=~s/\.(\w+)\_\_\_/(\\.\\d+)*\\.$1/; 9203: } 9204: my $cname=$env{'course.'.$env{'request.course.id'}.'.num'}; 9205: my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'}; 9206: return &log_query($cname,$cdom,'courselog',%filters); 9207: } 9208: 9209: sub userlog_query { 9210: # 9211: # possible filters: 9212: # action: log check role 9213: # start: timestamp 9214: # end: timestamp 9215: # 9216: my ($uname,$udom,%filters)=@_; 9217: return &log_query($uname,$udom,'userlog',%filters); 9218: } 9219: 9220: #--------- Call auto-enrollment subs in localenroll.pm for homeserver for course 9221: 9222: sub auto_run { 9223: my ($cnum,$cdom) = @_; 9224: my $response = 0; 9225: my $settings; 9226: my %domconfig = &get_dom('configuration',['autoenroll'],$cdom); 9227: if (ref($domconfig{'autoenroll'}) eq 'HASH') { 9228: $settings = $domconfig{'autoenroll'}; 9229: if ($settings->{'run'} eq '1') { 9230: $response = 1; 9231: } 9232: } else { 9233: my $homeserver; 9234: if (&is_course($cdom,$cnum)) { 9235: $homeserver = &homeserver($cnum,$cdom); 9236: } else { 9237: $homeserver = &domain($cdom,'primary'); 9238: } 9239: if ($homeserver ne 'no_host') { 9240: $response = &reply('autorun:'.$cdom,$homeserver); 9241: } 9242: } 9243: return $response; 9244: } 9245: 9246: sub auto_get_sections { 9247: my ($cnum,$cdom,$inst_coursecode) = @_; 9248: my $homeserver; 9249: if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { 9250: $homeserver = &homeserver($cnum,$cdom); 9251: } 9252: if (!defined($homeserver)) { 9253: if ($cdom =~ /^$match_domain$/) { 9254: $homeserver = &domain($cdom,'primary'); 9255: } 9256: } 9257: my @secs; 9258: if (defined($homeserver)) { 9259: my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); 9260: unless ($response eq 'refused') { 9261: @secs = split(/:/,$response); 9262: } 9263: } 9264: return @secs; 9265: } 9266: 9267: sub auto_new_course { 9268: my ($cnum,$cdom,$inst_course_id,$owner,$coowners) = @_; 9269: my $homeserver = &homeserver($cnum,$cdom); 9270: my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.&escape($owner).':'.$cdom.':'.&escape($coowners),$homeserver)); 9271: return $response; 9272: } 9273: 9274: sub auto_validate_courseID { 9275: my ($cnum,$cdom,$inst_course_id) = @_; 9276: my $homeserver = &homeserver($cnum,$cdom); 9277: my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); 9278: return $response; 9279: } 9280: 9281: sub auto_validate_instcode { 9282: my ($cnum,$cdom,$instcode,$owner) = @_; 9283: my ($homeserver,$response); 9284: if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { 9285: $homeserver = &homeserver($cnum,$cdom); 9286: } 9287: if (!defined($homeserver)) { 9288: if ($cdom =~ /^$match_domain$/) { 9289: $homeserver = &domain($cdom,'primary'); 9290: } 9291: } 9292: $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. 9293: &escape($instcode).':'.&escape($owner),$homeserver)); 9294: my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3); 9295: return ($outcome,$description,$defaultcredits); 9296: } 9297: 9298: sub auto_create_password { 9299: my ($cnum,$cdom,$authparam,$udom) = @_; 9300: my ($homeserver,$response); 9301: my $create_passwd = 0; 9302: my $authchk = ''; 9303: if ($udom =~ /^$match_domain$/) { 9304: $homeserver = &domain($udom,'primary'); 9305: } 9306: if ($homeserver eq '') { 9307: if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { 9308: $homeserver = &homeserver($cnum,$cdom); 9309: } 9310: } 9311: if ($homeserver eq '') { 9312: $authchk = 'nodomain'; 9313: } else { 9314: $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); 9315: if ($response eq 'refused') { 9316: $authchk = 'refused'; 9317: } else { 9318: ($authparam,$create_passwd,$authchk) = split(/:/,$response); 9319: } 9320: } 9321: return ($authparam,$create_passwd,$authchk); 9322: } 9323: 9324: sub auto_photo_permission { 9325: my ($cnum,$cdom,$students) = @_; 9326: my $homeserver = &homeserver($cnum,$cdom); 9327: my ($outcome,$perm_reqd,$conditions) = 9328: split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3); 9329: if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) { 9330: return (undef,undef); 9331: } 9332: return ($outcome,$perm_reqd,$conditions); 9333: } 9334: 9335: sub auto_checkphotos { 9336: my ($uname,$udom,$pid) = @_; 9337: my $homeserver = &homeserver($uname,$udom); 9338: my ($result,$resulttype); 9339: my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'. 9340: &escape($uname).':'.&escape($pid), 9341: $homeserver)); 9342: if ($outcome =~ /^(con_lost|unknown_cmd|no_such_host)$/) { 9343: return (undef,undef); 9344: } 9345: if ($outcome) { 9346: ($result,$resulttype) = split(/:/,$outcome); 9347: } 9348: return ($result,$resulttype); 9349: } 9350: 9351: sub auto_photochoice { 9352: my ($cnum,$cdom) = @_; 9353: my $homeserver = &homeserver($cnum,$cdom); 9354: my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'. 9355: &escape($cdom), 9356: $homeserver))); 9357: if ($update =~ /^(con_lost|unknown_cmd|no_such_host)$/) { 9358: return (undef,undef); 9359: } 9360: return ($update,$comment); 9361: } 9362: 9363: sub auto_photoupdate { 9364: my ($affiliatesref,$dom,$cnum,$photo) = @_; 9365: my $homeserver = &homeserver($cnum,$dom); 9366: my $host=&hostname($homeserver); 9367: my $cmd = ''; 9368: my $maxtries = 1; 9369: foreach my $affiliate (keys(%{$affiliatesref})) { 9370: $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; 9371: } 9372: $cmd =~ s/%%$//; 9373: $cmd = &escape($cmd); 9374: my $query = 'institutionalphotos'; 9375: my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver); 9376: unless ($queryid=~/^\Q$host\E\_/) { 9377: &logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$cnum); 9378: return 'error: '.$queryid; 9379: } 9380: my $reply = &get_query_reply($queryid); 9381: my $tries = 1; 9382: while (($reply=~/^timeout/) && ($tries < $maxtries)) { 9383: $reply = &get_query_reply($queryid); 9384: $tries ++; 9385: } 9386: if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { 9387: &logthis('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); 9388: } else { 9389: my @responses = split(/:/,$reply); 9390: my $outcome = shift(@responses); 9391: foreach my $item (@responses) { 9392: my ($key,$value) = split(/=/,$item); 9393: $$photo{$key} = $value; 9394: } 9395: return $outcome; 9396: } 9397: return 'error'; 9398: } 9399: 9400: sub auto_instcode_format { 9401: my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles, 9402: $cat_order) = @_; 9403: my $courses = ''; 9404: my @homeservers; 9405: if ($caller eq 'global') { 9406: my %servers = &get_servers($codedom,'library'); 9407: foreach my $tryserver (keys(%servers)) { 9408: if (!grep(/^\Q$tryserver\E$/,@homeservers)) { 9409: push(@homeservers,$tryserver); 9410: } 9411: } 9412: } elsif ($caller eq 'requests') { 9413: if ($codedom =~ /^$match_domain$/) { 9414: my $chome = &domain($codedom,'primary'); 9415: unless ($chome eq 'no_host') { 9416: push(@homeservers,$chome); 9417: } 9418: } 9419: } else { 9420: push(@homeservers,&homeserver($caller,$codedom)); 9421: } 9422: foreach my $code (keys(%{$instcodes})) { 9423: $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&'; 9424: } 9425: chop($courses); 9426: my $ok_response = 0; 9427: my $response; 9428: while (@homeservers > 0 && $ok_response == 0) { 9429: my $server = shift(@homeservers); 9430: $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); 9431: if ($response !~ /(con_lost|error|no_such_host|refused)/) { 9432: my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 9433: split(/:/,$response); 9434: %{$codes} = (%{$codes},&str2hash($codes_str)); 9435: push(@{$codetitles},&str2array($codetitles_str)); 9436: %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); 9437: %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str)); 9438: $ok_response = 1; 9439: } 9440: } 9441: if ($ok_response) { 9442: return 'ok'; 9443: } else { 9444: return $response; 9445: } 9446: } 9447: 9448: sub auto_instcode_defaults { 9449: my ($domain,$returnhash,$code_order) = @_; 9450: my @homeservers; 9451: 9452: my %servers = &get_servers($domain,'library'); 9453: foreach my $tryserver (keys(%servers)) { 9454: if (!grep(/^\Q$tryserver\E$/,@homeservers)) { 9455: push(@homeservers,$tryserver); 9456: } 9457: } 9458: 9459: my $response; 9460: foreach my $server (@homeservers) { 9461: $response=&reply('autoinstcodedefaults:'.$domain,$server); 9462: next if ($response =~ /(con_lost|error|no_such_host|refused)/); 9463: 9464: foreach my $pair (split(/\&/,$response)) { 9465: my ($name,$value)=split(/\=/,$pair); 9466: if ($name eq 'code_order') { 9467: @{$code_order} = split(/\&/,&unescape($value)); 9468: } else { 9469: $returnhash->{&unescape($name)}=&unescape($value); 9470: } 9471: } 9472: return 'ok'; 9473: } 9474: 9475: return $response; 9476: } 9477: 9478: sub auto_possible_instcodes { 9479: my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_; 9480: unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && 9481: (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { 9482: return; 9483: } 9484: my (@homeservers,$uhome); 9485: if (defined(&domain($domain,'primary'))) { 9486: $uhome=&domain($domain,'primary'); 9487: push(@homeservers,&domain($domain,'primary')); 9488: } else { 9489: my %servers = &get_servers($domain,'library'); 9490: foreach my $tryserver (keys(%servers)) { 9491: if (!grep(/^\Q$tryserver\E$/,@homeservers)) { 9492: push(@homeservers,$tryserver); 9493: } 9494: } 9495: } 9496: my $response; 9497: foreach my $server (@homeservers) { 9498: $response=&reply('autopossibleinstcodes:'.$domain,$server); 9499: next if ($response =~ /(con_lost|error|no_such_host|refused)/); 9500: my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = 9501: split(':',$response); 9502: @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr)); 9503: @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr)); 9504: foreach my $item (split('&',$cat_title)) { 9505: my ($name,$value)=split('=',$item); 9506: $cat_titles->{&unescape($name)}=&thaw_unescape($value); 9507: } 9508: foreach my $item (split('&',$cat_order)) { 9509: my ($name,$value)=split('=',$item); 9510: $cat_orders->{&unescape($name)}=&thaw_unescape($value); 9511: } 9512: return 'ok'; 9513: } 9514: return $response; 9515: } 9516: 9517: sub auto_courserequest_checks { 9518: my ($dom) = @_; 9519: my ($homeserver,%validations); 9520: if ($dom =~ /^$match_domain$/) { 9521: $homeserver = &domain($dom,'primary'); 9522: } 9523: unless ($homeserver eq 'no_host') { 9524: my $response=&reply('autocrsreqchecks:'.$dom,$homeserver); 9525: unless ($response =~ /(con_lost|error|no_such_host|refused)/) { 9526: my @items = split(/&/,$response); 9527: foreach my $item (@items) { 9528: my ($key,$value) = split('=',$item); 9529: $validations{&unescape($key)} = &thaw_unescape($value); 9530: } 9531: } 9532: } 9533: return %validations; 9534: } 9535: 9536: sub auto_courserequest_validation { 9537: my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_; 9538: my ($homeserver,$response); 9539: if ($dom =~ /^$match_domain$/) { 9540: $homeserver = &domain($dom,'primary'); 9541: } 9542: unless ($homeserver eq 'no_host') { 9543: my $customdata; 9544: if (ref($custominfo) eq 'HASH') { 9545: $customdata = &freeze_escape($custominfo); 9546: } 9547: $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner). 9548: ':'.&escape($crstype).':'.&escape($inststatuslist). 9549: ':'.&escape($instcode).':'.&escape($instseclist).':'. 9550: $customdata,$homeserver)); 9551: } 9552: return $response; 9553: } 9554: 9555: sub auto_validate_class_sec { 9556: my ($cdom,$cnum,$owners,$inst_class) = @_; 9557: my $homeserver = &homeserver($cnum,$cdom); 9558: my $ownerlist; 9559: if (ref($owners) eq 'ARRAY') { 9560: $ownerlist = join(',',@{$owners}); 9561: } else { 9562: $ownerlist = $owners; 9563: } 9564: my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. 9565: &escape($ownerlist).':'.$cdom,$homeserver); 9566: return $response; 9567: } 9568: 9569: sub auto_validate_instclasses { 9570: my ($cdom,$cnum,$owners,$classesref) = @_; 9571: my ($homeserver,%validations); 9572: $homeserver = &homeserver($cnum,$cdom); 9573: unless ($homeserver eq 'no_host') { 9574: my $ownerlist; 9575: if (ref($owners) eq 'ARRAY') { 9576: $ownerlist = join(',',@{$owners}); 9577: } else { 9578: $ownerlist = $owners; 9579: } 9580: if (ref($classesref) eq 'HASH') { 9581: my $classes = &freeze_escape($classesref); 9582: my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist). 9583: ':'.$cdom.':'.$classes,$homeserver); 9584: unless ($response =~ /(con_lost|error|no_such_host|refused)/) { 9585: my @items = split(/&/,$response); 9586: foreach my $item (@items) { 9587: my ($key,$value) = split('=',$item); 9588: $validations{&unescape($key)} = &thaw_unescape($value); 9589: } 9590: } 9591: } 9592: } 9593: return %validations; 9594: } 9595: 9596: sub auto_crsreq_update { 9597: my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, 9598: $code,$accessstart,$accessend,$inbound) = @_; 9599: my ($homeserver,%crsreqresponse); 9600: if ($cdom =~ /^$match_domain$/) { 9601: $homeserver = &domain($cdom,'primary'); 9602: } 9603: unless (($homeserver eq 'no_host') || ($homeserver eq '')) { 9604: my $info; 9605: if (ref($inbound) eq 'HASH') { 9606: $info = &freeze_escape($inbound); 9607: } 9608: my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype). 9609: ':'.&escape($action).':'.&escape($ownername).':'. 9610: &escape($ownerdomain).':'.&escape($fullname).':'. 9611: &escape($title).':'.&escape($code).':'. 9612: &escape($accessstart).':'.&escape($accessend).':'.$info, 9613: $homeserver); 9614: unless ($response =~ /(con_lost|error|no_such_host|refused)/) { 9615: my @items = split(/&/,$response); 9616: foreach my $item (@items) { 9617: my ($key,$value) = split('=',$item); 9618: $crsreqresponse{&unescape($key)} = &thaw_unescape($value); 9619: } 9620: } 9621: } 9622: return \%crsreqresponse; 9623: } 9624: 9625: sub auto_export_grades { 9626: my ($cdom,$cnum,$inforef,$gradesref) = @_; 9627: my ($homeserver,%exportresponse); 9628: if ($cdom =~ /^$match_domain$/) { 9629: $homeserver = &domain($cdom,'primary'); 9630: } 9631: unless (($homeserver eq 'no_host') || ($homeserver eq '')) { 9632: my $info; 9633: if (ref($inforef) eq 'HASH') { 9634: $info = &freeze_escape($inforef); 9635: } 9636: if (ref($gradesref) eq 'HASH') { 9637: my $grades = &freeze_escape($gradesref); 9638: my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'. 9639: $info.':'.$grades,$homeserver); 9640: unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) { 9641: my @items = split(/&/,$response); 9642: foreach my $item (@items) { 9643: my ($key,$value) = split('=',$item); 9644: $exportresponse{&unescape($key)} = &thaw_unescape($value); 9645: } 9646: } 9647: } 9648: } 9649: return \%exportresponse; 9650: } 9651: 9652: sub check_instcode_cloning { 9653: my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; 9654: unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { 9655: return; 9656: } 9657: my $canclone; 9658: if (@{$code_order} > 0) { 9659: my $instcoderegexp ='^'; 9660: my @clonecodes = split(/\&/,$cloner); 9661: foreach my $item (@{$code_order}) { 9662: if (grep(/^\Q$item\E=/,@clonecodes)) { 9663: foreach my $pair (@clonecodes) { 9664: my ($key,$val) = split(/\=/,$pair,2); 9665: $val = &unescape($val); 9666: if ($key eq $item) { 9667: $instcoderegexp .= '('.$val.')'; 9668: last; 9669: } 9670: } 9671: } else { 9672: $instcoderegexp .= $codedefaults->{$item}; 9673: } 9674: } 9675: $instcoderegexp .= '$'; 9676: my (@from,@to); 9677: eval { 9678: (@from) = ($clonefromcode =~ /$instcoderegexp/); 9679: (@to) = ($clonetocode =~ /$instcoderegexp/); 9680: }; 9681: if ((@from > 0) && (@to > 0)) { 9682: my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); 9683: if (!@diffs) { 9684: $canclone = 1; 9685: } 9686: } 9687: } 9688: return $canclone; 9689: } 9690: 9691: sub default_instcode_cloning { 9692: my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_; 9693: my (%codedefaults,@code_order,$canclone); 9694: if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) { 9695: %codedefaults = %{$codedefaultsref}; 9696: @code_order = @{$codeorderref}; 9697: } elsif ($clonedom) { 9698: &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order); 9699: } 9700: if (($domdefclone) && (@code_order)) { 9701: my @clonecodes = split(/\+/,$domdefclone); 9702: my $instcoderegexp ='^'; 9703: foreach my $item (@code_order) { 9704: if (grep(/^\Q$item\E$/,@clonecodes)) { 9705: $instcoderegexp .= '('.$codedefaults{$item}.')'; 9706: } else { 9707: $instcoderegexp .= $codedefaults{$item}; 9708: } 9709: } 9710: $instcoderegexp .= '$'; 9711: my (@from,@to); 9712: eval { 9713: (@from) = ($clonefromcode =~ /$instcoderegexp/); 9714: (@to) = ($clonetocode =~ /$instcoderegexp/); 9715: }; 9716: if ((@from > 0) && (@to > 0)) { 9717: my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); 9718: if (!@diffs) { 9719: $canclone = 1; 9720: } 9721: } 9722: } 9723: return $canclone; 9724: } 9725: 9726: # ------------------------------------------------------- Course Group routines 9727: 9728: sub get_coursegroups { 9729: my ($cdom,$cnum,$group,$namespace) = @_; 9730: return(&dump($namespace,$cdom,$cnum,$group)); 9731: } 9732: 9733: sub modify_coursegroup { 9734: my ($cdom,$cnum,$groupsettings) = @_; 9735: return(&put('coursegroups',$groupsettings,$cdom,$cnum)); 9736: } 9737: 9738: sub toggle_coursegroup_status { 9739: my ($cdom,$cnum,$group,$action) = @_; 9740: my ($from_namespace,$to_namespace); 9741: if ($action eq 'delete') { 9742: $from_namespace = 'coursegroups'; 9743: $to_namespace = 'deleted_groups'; 9744: } else { 9745: $from_namespace = 'deleted_groups'; 9746: $to_namespace = 'coursegroups'; 9747: } 9748: my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace); 9749: if (my $tmp = &error(%curr_group)) { 9750: &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom); 9751: return ('read error',$tmp); 9752: } else { 9753: my %savedsettings = %curr_group; 9754: my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum); 9755: my $deloutcome; 9756: if ($result eq 'ok') { 9757: $deloutcome = &del($from_namespace,[$group],$cdom,$cnum); 9758: } else { 9759: return ('write error',$result); 9760: } 9761: if ($deloutcome eq 'ok') { 9762: return 'ok'; 9763: } else { 9764: return ('delete error',$deloutcome); 9765: } 9766: } 9767: } 9768: 9769: sub modify_group_roles { 9770: my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_; 9771: my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; 9772: my $role = 'gr/'.&escape($userprivs); 9773: my ($uname,$udom) = split(/:/,$user); 9774: my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context); 9775: if ($result eq 'ok') { 9776: &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); 9777: } 9778: return $result; 9779: } 9780: 9781: sub modify_coursegroup_membership { 9782: my ($cdom,$cnum,$membership) = @_; 9783: my $result = &put('groupmembership',$membership,$cdom,$cnum); 9784: return $result; 9785: } 9786: 9787: sub get_active_groups { 9788: my ($udom,$uname,$cdom,$cnum) = @_; 9789: my $now = time; 9790: my %groups = (); 9791: foreach my $key (keys(%env)) { 9792: if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) { 9793: my ($start,$end) = split(/\./,$env{$key}); 9794: if (($end!=0) && ($end<$now)) { next; } 9795: if (($start!=0) && ($start>$now)) { next; } 9796: if ($1 eq $cdom && $2 eq $cnum) { 9797: $groups{$3} = $env{$key} ; 9798: } 9799: } 9800: } 9801: return %groups; 9802: } 9803: 9804: sub get_group_membership { 9805: my ($cdom,$cnum,$group) = @_; 9806: return(&dump('groupmembership',$cdom,$cnum,$group)); 9807: } 9808: 9809: sub get_users_groups { 9810: my ($udom,$uname,$courseid) = @_; 9811: my @usersgroups; 9812: my $cachetime=1800; 9813: 9814: my $hashid="$udom:$uname:$courseid"; 9815: my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid); 9816: if (defined($cached)) { 9817: @usersgroups = split(/:/,$grouplist); 9818: } else { 9819: $grouplist = ''; 9820: my $courseurl = &courseid_to_courseurl($courseid); 9821: my %roleshash = &dump('roles',$udom,$uname,$courseurl); 9822: my $access_end = $env{'course.'.$courseid. 9823: '.default_enrollment_end_date'}; 9824: my $now = time; 9825: foreach my $key (keys(%roleshash)) { 9826: if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) { 9827: my $group = $1; 9828: if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { 9829: my $start = $2; 9830: my $end = $1; 9831: if ($start == -1) { next; } # deleted from group 9832: if (($start!=0) && ($start>$now)) { next; } 9833: if (($end!=0) && ($end<$now)) { 9834: if ($access_end && $access_end < $now) { 9835: if ($access_end - $end < 86400) { 9836: push(@usersgroups,$group); 9837: } 9838: } 9839: next; 9840: } 9841: push(@usersgroups,$group); 9842: } 9843: } 9844: } 9845: @usersgroups = &sort_course_groups($courseid,@usersgroups); 9846: $grouplist = join(':',@usersgroups); 9847: &do_cache_new('getgroups',$hashid,$grouplist,$cachetime); 9848: } 9849: return @usersgroups; 9850: } 9851: 9852: sub devalidate_getgroups_cache { 9853: my ($udom,$uname,$cdom,$cnum)=@_; 9854: my $courseid = $cdom.'_'.$cnum; 9855: 9856: my $hashid="$udom:$uname:$courseid"; 9857: &devalidate_cache_new('getgroups',$hashid); 9858: } 9859: 9860: # ------------------------------------------------------------------ Plain Text 9861: 9862: sub plaintext { 9863: my ($short,$type,$cid,$forcedefault) = @_; 9864: if ($short =~ m{^cr/}) { 9865: return (split('/',$short))[-1]; 9866: } 9867: if (!defined($cid)) { 9868: $cid = $env{'request.course.id'}; 9869: } 9870: my %rolenames = ( 9871: Course => 'std', 9872: Community => 'alt1', 9873: Placement => 'std', 9874: ); 9875: if ($cid ne '') { 9876: if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') { 9877: unless ($forcedefault) { 9878: my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; 9879: &Apache::lonlocal::mt_escape(\$roletext); 9880: return &Apache::lonlocal::mt($roletext); 9881: } 9882: } 9883: } 9884: if ((defined($type)) && (defined($rolenames{$type})) && 9885: (defined($rolenames{$type})) && 9886: (defined($prp{$short}{$rolenames{$type}}))) { 9887: return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); 9888: } elsif ($cid ne '') { 9889: my $crstype = $env{'course.'.$cid.'.type'}; 9890: if (($crstype ne '') && (defined($rolenames{$crstype})) && 9891: (defined($prp{$short}{$rolenames{$crstype}}))) { 9892: return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}}); 9893: } 9894: } 9895: return &Apache::lonlocal::mt($prp{$short}{'std'}); 9896: } 9897: 9898: # ----------------------------------------------------------------- Assign Role 9899: 9900: sub assignrole { 9901: my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll, 9902: $context)=@_; 9903: my $mrole; 9904: if ($role =~ /^cr\//) { 9905: my $cwosec=$url; 9906: $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; 9907: unless (&allowed('ccr',$cwosec)) { 9908: my $refused = 1; 9909: if ($context eq 'requestcourses') { 9910: if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { 9911: if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) { 9912: if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) { 9913: my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); 9914: my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); 9915: if ($crsenv{'internal.courseowner'} eq 9916: $env{'user.name'}.':'.$env{'user.domain'}) { 9917: $refused = ''; 9918: } 9919: } 9920: } 9921: } 9922: } 9923: if ($refused) { 9924: &logthis('Refused custom assignrole: '. 9925: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start. 9926: ' by '.$env{'user.name'}.' at '.$env{'user.domain'}); 9927: return 'refused'; 9928: } 9929: } 9930: $mrole='cr'; 9931: } elsif ($role =~ /^gr\//) { 9932: my $cwogrp=$url; 9933: $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2}; 9934: unless (&allowed('mdg',$cwogrp)) { 9935: &logthis('Refused group assignrole: '. 9936: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. 9937: $env{'user.name'}.' at '.$env{'user.domain'}); 9938: return 'refused'; 9939: } 9940: $mrole='gr'; 9941: } else { 9942: my $cwosec=$url; 9943: $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; 9944: if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) { 9945: my $refused; 9946: if (($env{'request.course.sec'} ne '') && ($role eq 'st')) { 9947: if (!(&allowed('c'.$role,$url))) { 9948: $refused = 1; 9949: } 9950: } else { 9951: $refused = 1; 9952: } 9953: if ($refused) { 9954: my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); 9955: if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) { 9956: my %crsenv; 9957: if ($role eq 'cc' || $role eq 'co') { 9958: %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); 9959: if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) { 9960: if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) { 9961: if ($crsenv{'internal.courseowner'} eq 9962: $env{'user.name'}.':'.$env{'user.domain'}) { 9963: $refused = ''; 9964: } 9965: } 9966: } elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) { 9967: if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) { 9968: if ($crsenv{'internal.courseowner'} eq 9969: $env{'user.name'}.':'.$env{'user.domain'}) { 9970: $refused = ''; 9971: } 9972: } 9973: } 9974: } 9975: } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { 9976: if ($role eq 'st') { 9977: $refused = ''; 9978: } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) { 9979: $refused = ''; 9980: } 9981: } elsif ($context eq 'requestcourses') { 9982: my @possroles = ('st','ta','ep','in','cc','co'); 9983: if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { 9984: my $wrongcc; 9985: if ($cnum =~ /^$match_community$/) { 9986: $wrongcc = 1 if ($role eq 'cc'); 9987: } else { 9988: $wrongcc = 1 if ($role eq 'co'); 9989: } 9990: unless ($wrongcc) { 9991: my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); 9992: if ($crsenv{'internal.courseowner'} eq 9993: $env{'user.name'}.':'.$env{'user.domain'}) { 9994: $refused = ''; 9995: } 9996: } 9997: } 9998: } elsif ($context eq 'requestauthor') { 9999: if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && 10000: ($url eq '/'.$udom.'/') && ($role eq 'au')) { 10001: if ($env{'environment.requestauthor'} eq 'automatic') { 10002: $refused = ''; 10003: } else { 10004: my %domdefaults = &get_domain_defaults($udom); 10005: if (ref($domdefaults{'requestauthor'}) eq 'HASH') { 10006: my $checkbystatus; 10007: if ($env{'user.adv'}) { 10008: my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; 10009: if ($disposition eq 'automatic') { 10010: $refused = ''; 10011: } elsif ($disposition eq '') { 10012: $checkbystatus = 1; 10013: } 10014: } else { 10015: $checkbystatus = 1; 10016: } 10017: if ($checkbystatus) { 10018: if ($env{'environment.inststatus'}) { 10019: my @inststatuses = split(/,/,$env{'environment.inststatus'}); 10020: foreach my $type (@inststatuses) { 10021: if (($type ne '') && 10022: ($domdefaults{'requestauthor'}{$type} eq 'automatic')) { 10023: $refused = ''; 10024: } 10025: } 10026: } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') { 10027: $refused = ''; 10028: } 10029: } 10030: } 10031: } 10032: } 10033: } 10034: if ($refused) { 10035: &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. 10036: ' '.$role.' '.$end.' '.$start.' by '. 10037: $env{'user.name'}.' at '.$env{'user.domain'}); 10038: return 'refused'; 10039: } 10040: } 10041: } elsif ($role eq 'au') { 10042: if ($url ne '/'.$udom.'/') { 10043: &logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}. 10044: ' to assign author role for '.$uname.':'.$udom. 10045: ' in domain: '.$url.' refused (wrong domain).'); 10046: return 'refused'; 10047: } 10048: } 10049: $mrole=$role; 10050: } 10051: my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". 10052: "$udom:$uname:$url".'_'."$mrole=$role"; 10053: if ($end) { $command.='_'.$end; } 10054: if ($start) { 10055: if ($end) { 10056: $command.='_'.$start; 10057: } else { 10058: $command.='_0_'.$start; 10059: } 10060: } 10061: my $origstart = $start; 10062: my $origend = $end; 10063: my $delflag; 10064: # actually delete 10065: if ($deleteflag) { 10066: if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { 10067: # modify command to delete the role 10068: $command="encrypt:rolesdel:$env{'user.domain'}:$env{'user.name'}:". 10069: "$udom:$uname:$url".'_'."$mrole"; 10070: &logthis("$env{'user.name'} at $env{'user.domain'} deletes $mrole in $url for $uname at $udom"); 10071: # set start and finish to negative values for userrolelog 10072: $start=-1; 10073: $end=-1; 10074: $delflag = 1; 10075: } 10076: } 10077: # send command 10078: my $answer=&reply($command,&homeserver($uname,$udom)); 10079: # log new user role if status is ok 10080: if ($answer eq 'ok') { 10081: &userrolelog($role,$uname,$udom,$url,$start,$end); 10082: if (($role eq 'cc') || ($role eq 'in') || 10083: ($role eq 'ep') || ($role eq 'ad') || 10084: ($role eq 'ta') || ($role eq 'st') || 10085: ($role=~/^cr/) || ($role eq 'gr') || 10086: ($role eq 'co')) { 10087: # for course roles, perform group memberships changes triggered by role change. 10088: unless ($role =~ /^gr/) { 10089: &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, 10090: $origstart,$selfenroll,$context); 10091: } 10092: &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, 10093: $selfenroll,$context); 10094: } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || 10095: ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') || 10096: ($role eq 'da')) { 10097: &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, 10098: $context); 10099: } elsif (($role eq 'ca') || ($role eq 'aa')) { 10100: &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, 10101: $context); 10102: } 10103: if ($role eq 'cc') { 10104: &autoupdate_coowners($url,$end,$start,$uname,$udom); 10105: } 10106: } 10107: return $answer; 10108: } 10109: 10110: sub autoupdate_coowners { 10111: my ($url,$end,$start,$uname,$udom) = @_; 10112: my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)}); 10113: if (($cdom ne '') && ($cnum ne '')) { 10114: my $now = time; 10115: my %domdesign = &Apache::loncommon::get_domainconf($cdom); 10116: if ($domdesign{$cdom.'.autoassign.co-owners'}) { 10117: my %coursehash = &coursedescription($cdom.'_'.$cnum); 10118: my $instcode = $coursehash{'internal.coursecode'}; 10119: if ($instcode ne '') { 10120: if (($start && $start <= $now) && ($end == 0) || ($end > $now)) { 10121: unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) { 10122: my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners); 10123: my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom); 10124: if ($result eq 'valid') { 10125: if ($coursehash{'internal.co-owners'}) { 10126: foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { 10127: push(@newcoowners,$coowner); 10128: } 10129: unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) { 10130: push(@newcoowners,$uname.':'.$udom); 10131: } 10132: @newcoowners = sort(@newcoowners); 10133: } else { 10134: push(@newcoowners,$uname.':'.$udom); 10135: } 10136: } else { 10137: if ($coursehash{'internal.co-owners'}) { 10138: foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { 10139: unless ($coowner eq $uname.':'.$udom) { 10140: push(@newcoowners,$coowner); 10141: } 10142: } 10143: unless (@newcoowners > 0) { 10144: $delcoowners = 1; 10145: $coowners = ''; 10146: } 10147: } 10148: } 10149: if (@newcoowners || $delcoowners) { 10150: &store_coowners($cdom,$cnum,$coursehash{'home'}, 10151: $delcoowners,@newcoowners); 10152: } 10153: } 10154: } 10155: } 10156: } 10157: } 10158: } 10159: 10160: sub store_coowners { 10161: my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_; 10162: my $cid = $cdom.'_'.$cnum; 10163: my ($coowners,$delresult,$putresult); 10164: if (@newcoowners) { 10165: $coowners = join(',',@newcoowners); 10166: my %coownershash = ( 10167: 'internal.co-owners' => $coowners, 10168: ); 10169: $putresult = &put('environment',\%coownershash,$cdom,$cnum); 10170: if ($putresult eq 'ok') { 10171: if ($env{'course.'.$cid.'.num'} eq $cnum) { 10172: &appenv({'course.'.$cid.'.internal.co-owners' => $coowners}); 10173: } 10174: } 10175: } 10176: if ($delcoowners) { 10177: $delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum); 10178: if ($delresult eq 'ok') { 10179: if ($env{'course.'.$cid.'.internal.co-owners'}) { 10180: &Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners'); 10181: } 10182: } 10183: } 10184: if (($putresult eq 'ok') || ($delresult eq 'ok')) { 10185: my %crsinfo = 10186: &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); 10187: if (ref($crsinfo{$cid}) eq 'HASH') { 10188: $crsinfo{$cid}{'co-owners'} = \@newcoowners; 10189: my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime'); 10190: } 10191: } 10192: } 10193: 10194: # -------------------------------------------------- Modify user authentication 10195: # Overrides without validation 10196: 10197: sub modifyuserauth { 10198: my ($udom,$uname,$umode,$upass)=@_; 10199: my $uhome=&homeserver($uname,$udom); 10200: my $allowed; 10201: if (&allowed('mau',$udom)) { 10202: $allowed = 1; 10203: } elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) && 10204: ($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) && 10205: (!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) { 10206: my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 10207: my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; 10208: if (($cdom ne '') && ($cnum ne '')) { 10209: my $is_owner = &is_course_owner($cdom,$cnum); 10210: if ($is_owner) { 10211: $allowed = 1; 10212: } 10213: } 10214: } 10215: unless ($allowed) { return 'refused'; } 10216: &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. 10217: $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}. 10218: ' in domain '.$env{'request.role.domain'}); 10219: my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. 10220: &escape($upass),$uhome); 10221: &log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, 10222: 'Authentication changed for '.$udom.', '.$uname.', '.$umode. 10223: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); 10224: &log($udom,,$uname,$uhome, 10225: 'Authentication changed by '.$env{'user.domain'}.', '. 10226: $env{'user.name'}.', '.$umode. 10227: '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); 10228: unless ($reply eq 'ok') { 10229: &logthis('Authentication mode error: '.$reply); 10230: return 'error: '.$reply; 10231: } 10232: return 'ok'; 10233: } 10234: 10235: # --------------------------------------------------------------- Modify a user 10236: 10237: sub modifyuser { 10238: my ($udom, $uname, $uid, 10239: $umode, $upass, $first, 10240: $middle, $last, $gene, 10241: $forceid, $desiredhome, $email, $inststatus, $candelete)=@_; 10242: $udom= &LONCAPA::clean_domain($udom); 10243: $uname=&LONCAPA::clean_username($uname); 10244: my $showcandelete = 'none'; 10245: if (ref($candelete) eq 'ARRAY') { 10246: if (@{$candelete} > 0) { 10247: $showcandelete = join(', ',@{$candelete}); 10248: } 10249: } 10250: &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. 10251: $umode.', '.$first.', '.$middle.', '. 10252: $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. 10253: (defined($desiredhome) ? ' desiredhome = '.$desiredhome : 10254: ' desiredhome not specified'). 10255: ' by '.$env{'user.name'}.' at '.$env{'user.domain'}. 10256: ' in domain '.$env{'request.role.domain'}); 10257: my $uhome=&homeserver($uname,$udom,'true'); 10258: my $newuser; 10259: if ($uhome eq 'no_host') { 10260: $newuser = 1; 10261: unless (($umode && ($upass ne '')) || ($umode eq 'localauth') || 10262: ($umode eq 'lti')) { 10263: return 'error: more information needed to create new user'; 10264: } 10265: } 10266: # ----------------------------------------------------------------- Create User 10267: if (($uhome eq 'no_host') && 10268: (($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) { 10269: my $unhome=''; 10270: if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 10271: $unhome = $desiredhome; 10272: } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { 10273: $unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; 10274: } else { # load balancing routine for determining $unhome 10275: my $loadm=10000000; 10276: my %servers = &get_servers($udom,'library'); 10277: foreach my $tryserver (keys(%servers)) { 10278: my $answer=reply('load',$tryserver); 10279: if (($answer=~/\d+/) && ($answer<$loadm)) { 10280: $loadm=$answer; 10281: $unhome=$tryserver; 10282: } 10283: } 10284: } 10285: if (($unhome eq '') || ($unhome eq 'no_host')) { 10286: return 'error: unable to find a home server for '.$uname. 10287: ' in domain '.$udom; 10288: } 10289: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'. 10290: &escape($upass),$unhome); 10291: unless ($reply eq 'ok') { 10292: return 'error: '.$reply; 10293: } 10294: $uhome=&homeserver($uname,$udom,'true'); 10295: if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { 10296: return 'error: unable verify users home machine.'; 10297: } 10298: } # End of creation of new user 10299: # ---------------------------------------------------------------------- Add ID 10300: if ($uid) { 10301: $uid=~tr/A-Z/a-z/; 10302: my %uidhash=&idrget($udom,$uname); 10303: if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) 10304: && (!$forceid)) { 10305: unless ($uid eq $uidhash{$uname}) { 10306: return 'error: user id "'.$uid.'" does not match '. 10307: 'current user id "'.$uidhash{$uname}.'".'; 10308: } 10309: } else { 10310: &idput($udom,{$uname => $uid},$uhome,'ids'); 10311: } 10312: } 10313: # -------------------------------------------------------------- Add names, etc 10314: my @tmp=&get('environment', 10315: ['firstname','middlename','lastname','generation','id', 10316: 'permanentemail','inststatus'], 10317: $udom,$uname); 10318: my (%names,%oldnames); 10319: if ($tmp[0] =~ m/^error:.*/) { 10320: %names=(); 10321: } else { 10322: %names = @tmp; 10323: %oldnames = %names; 10324: } 10325: # 10326: # If name, email and/or uid are blank (e.g., because an uploaded file 10327: # of users did not contain them), do not overwrite existing values 10328: # unless field is in $candelete array ref. 10329: # 10330: 10331: my @fields = ('firstname','middlename','lastname','generation', 10332: 'permanentemail','id'); 10333: my %newvalues; 10334: if (ref($candelete) eq 'ARRAY') { 10335: foreach my $field (@fields) { 10336: if (grep(/^\Q$field\E$/,@{$candelete})) { 10337: if ($field eq 'firstname') { 10338: $names{$field} = $first; 10339: } elsif ($field eq 'middlename') { 10340: $names{$field} = $middle; 10341: } elsif ($field eq 'lastname') { 10342: $names{$field} = $last; 10343: } elsif ($field eq 'generation') { 10344: $names{$field} = $gene; 10345: } elsif ($field eq 'permanentemail') { 10346: $names{$field} = $email; 10347: } elsif ($field eq 'id') { 10348: $names{$field} = $uid; 10349: } 10350: } 10351: } 10352: } 10353: if ($first) { $names{'firstname'} = $first; } 10354: if (defined($middle)) { $names{'middlename'} = $middle; } 10355: if ($last) { $names{'lastname'} = $last; } 10356: if (defined($gene)) { $names{'generation'} = $gene; } 10357: if ($email) { 10358: $email=~s/[^\w\@\.\-\,]//gs; 10359: if ($email=~/\@/) { $names{'permanentemail'} = $email; } 10360: } 10361: if ($uid) { $names{'id'} = $uid; } 10362: if (defined($inststatus)) { 10363: $names{'inststatus'} = ''; 10364: my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom); 10365: if (ref($usertypes) eq 'HASH') { 10366: my @okstatuses; 10367: foreach my $item (split(/:/,$inststatus)) { 10368: if (defined($usertypes->{$item})) { 10369: push(@okstatuses,$item); 10370: } 10371: } 10372: if (@okstatuses) { 10373: $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses); 10374: } 10375: } 10376: } 10377: my $logmsg = $udom.', '.$uname.', '.$uid.', '. 10378: $umode.', '.$first.', '.$middle.', '. 10379: $last.', '.$gene.', '.$email.', '.$inststatus; 10380: if ($env{'user.name'} ne '' && $env{'user.domain'}) { 10381: $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; 10382: } else { 10383: $logmsg .= ' during self creation'; 10384: } 10385: my $changed; 10386: if ($newuser) { 10387: $changed = 1; 10388: } else { 10389: foreach my $field (@fields) { 10390: if ($names{$field} ne $oldnames{$field}) { 10391: $changed = 1; 10392: last; 10393: } 10394: } 10395: } 10396: unless ($changed) { 10397: $logmsg = 'No changes in user information needed for: '.$logmsg; 10398: &logthis($logmsg); 10399: return 'ok'; 10400: } 10401: my $reply = &put('environment', \%names, $udom,$uname); 10402: if ($reply ne 'ok') { 10403: return 'error: '.$reply; 10404: } 10405: if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { 10406: &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom); 10407: } 10408: my $sqlresult = &update_allusers_table($uname,$udom,\%names); 10409: &devalidate_cache_new('namescache',$uname.':'.$udom); 10410: $logmsg = 'Success modifying user '.$logmsg; 10411: &logthis($logmsg); 10412: return 'ok'; 10413: } 10414: 10415: # -------------------------------------------------------------- Modify student 10416: 10417: sub modifystudent { 10418: my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, 10419: $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, 10420: $selfenroll,$context,$inststatus,$credits,$instsec)=@_; 10421: if (!$cid) { 10422: unless ($cid=$env{'request.course.id'}) { 10423: return 'not_in_class'; 10424: } 10425: } 10426: # --------------------------------------------------------------- Make the user 10427: my $reply=&modifyuser 10428: ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, 10429: $desiredhome,$email,$inststatus); 10430: unless ($reply eq 'ok') { return $reply; } 10431: # This will cause &modify_student_enrollment to get the uid from the 10432: # student's environment 10433: $uid = undef if (!$forceid); 10434: $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, 10435: $gene,$usec,$end,$start,$type,$locktype, 10436: $cid,$selfenroll,$context,$credits,$instsec); 10437: return $reply; 10438: } 10439: 10440: sub modify_student_enrollment { 10441: my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, 10442: $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_; 10443: my ($cdom,$cnum,$chome); 10444: if (!$cid) { 10445: unless ($cid=$env{'request.course.id'}) { 10446: return 'not_in_class'; 10447: } 10448: $cdom=$env{'course.'.$cid.'.domain'}; 10449: $cnum=$env{'course.'.$cid.'.num'}; 10450: } else { 10451: ($cdom,$cnum)=split(/_/,$cid); 10452: } 10453: $chome=$env{'course.'.$cid.'.home'}; 10454: if (!$chome) { 10455: $chome=&homeserver($cnum,$cdom); 10456: } 10457: if (!$chome) { return 'unknown_course'; } 10458: # Make sure the user exists 10459: my $uhome=&homeserver($uname,$udom); 10460: if (($uhome eq '') || ($uhome eq 'no_host')) { 10461: return 'error: no such user'; 10462: } 10463: # Get student data if we were not given enough information 10464: if (!defined($first) || $first eq '' || 10465: !defined($last) || $last eq '' || 10466: !defined($uid) || $uid eq '' || 10467: !defined($middle) || $middle eq '' || 10468: !defined($gene) || $gene eq '') { 10469: # They did not supply us with enough data to enroll the student, so 10470: # we need to pick up more information. 10471: my %tmp = &get('environment', 10472: ['firstname','middlename','lastname', 'generation','id'] 10473: ,$udom,$uname); 10474: 10475: #foreach my $key (keys(%tmp)) { 10476: # &logthis("key $key = ".$tmp{$key}); 10477: #} 10478: $first = $tmp{'firstname'} if (!defined($first) || $first eq ''); 10479: $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); 10480: $last = $tmp{'lastname'} if (!defined($last) || $last eq ''); 10481: $gene = $tmp{'generation'} if (!defined($gene) || $gene eq ''); 10482: $uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); 10483: } 10484: my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); 10485: my $user = "$uname:$udom"; 10486: my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); 10487: my $reply=cput('classlist', 10488: {$user => 10489: join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) }, 10490: $cdom,$cnum); 10491: if (($reply eq 'ok') || ($reply eq 'delayed')) { 10492: &devalidate_getsection_cache($udom,$uname,$cid); 10493: } else { 10494: return 'error: '.$reply; 10495: } 10496: # Add student role to user 10497: my $uurl='/'.$cid; 10498: $uurl=~s/\_/\//g; 10499: if ($usec) { 10500: $uurl.='/'.$usec; 10501: } 10502: my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef, 10503: $selfenroll,$context); 10504: if ($result ne 'ok') { 10505: if ($old_entry{$user} ne '') { 10506: $reply = &cput('classlist',\%old_entry,$cdom,$cnum); 10507: } else { 10508: $reply = &del('classlist',[$user],$cdom,$cnum); 10509: } 10510: } 10511: return $result; 10512: } 10513: 10514: sub format_name { 10515: my ($firstname,$middlename,$lastname,$generation,$first)=@_; 10516: my $name; 10517: if ($first ne 'lastname') { 10518: $name=$firstname.' '.$middlename.' '.$lastname.' '.$generation; 10519: } else { 10520: if ($lastname=~/\S/) { 10521: $name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename; 10522: $name=~s/\s+,/,/; 10523: } else { 10524: $name.= $firstname.' '.$middlename.' '.$generation; 10525: } 10526: } 10527: $name=~s/^\s+//; 10528: $name=~s/\s+$//; 10529: $name=~s/\s+/ /g; 10530: return $name; 10531: } 10532: 10533: # ------------------------------------------------- Write to course preferences 10534: 10535: sub writecoursepref { 10536: my ($courseid,%prefs)=@_; 10537: $courseid=~s/^\///; 10538: $courseid=~s/\_/\//g; 10539: my ($cdomain,$cnum)=split(/\//,$courseid); 10540: my $chome=homeserver($cnum,$cdomain); 10541: if (($chome eq '') || ($chome eq 'no_host')) { 10542: return 'error: no such course'; 10543: } 10544: my $cstring=''; 10545: foreach my $pref (keys(%prefs)) { 10546: $cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&'; 10547: } 10548: $cstring=~s/\&$//; 10549: return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); 10550: } 10551: 10552: # ---------------------------------------------------------- Make/modify course 10553: 10554: sub createcourse { 10555: my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, 10556: $course_owner,$crstype,$cnum,$context,$category)=@_; 10557: $url=&declutter($url); 10558: my $cid=''; 10559: if ($context eq 'requestcourses') { 10560: my $can_create = 0; 10561: my ($ownername,$ownerdom) = split(':',$course_owner); 10562: if ($udom eq $ownerdom) { 10563: if (&usertools_access($ownername,$ownerdom,$category,undef, 10564: $context)) { 10565: $can_create = 1; 10566: } 10567: } else { 10568: my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'. 10569: $category); 10570: if ($userenv{'reqcrsotherdom.'.$category} ne '') { 10571: my @curr = split(',',$userenv{'reqcrsotherdom.'.$category}); 10572: if (@curr > 0) { 10573: my @options = qw(approval validate autolimit); 10574: my $optregex = join('|',@options); 10575: if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) { 10576: $can_create = 1; 10577: } 10578: } 10579: } 10580: } 10581: if ($can_create) { 10582: unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) { 10583: unless (&allowed('ccc',$udom)) { 10584: return 'refused'; 10585: } 10586: } 10587: } else { 10588: return 'refused'; 10589: } 10590: } elsif (!&allowed('ccc',$udom)) { 10591: return 'refused'; 10592: } 10593: # --------------------------------------------------------------- Get Unique ID 10594: my $uname; 10595: if ($cnum =~ /^$match_courseid$/) { 10596: my $chome=&homeserver($cnum,$udom,'true'); 10597: if (($chome eq '') || ($chome eq 'no_host')) { 10598: $uname = $cnum; 10599: } else { 10600: $uname = &generate_coursenum($udom,$crstype); 10601: } 10602: } else { 10603: $uname = &generate_coursenum($udom,$crstype); 10604: } 10605: return $uname if ($uname =~ /^error/); 10606: # -------------------------------------------------- Check supplied server name 10607: if (!defined($course_server)) { 10608: if (defined(&domain($udom,'primary'))) { 10609: $course_server = &domain($udom,'primary'); 10610: } else { 10611: $course_server = $env{'user.home'}; 10612: } 10613: } 10614: my %host_servers = 10615: &Apache::lonnet::get_servers($udom,'library'); 10616: unless ($host_servers{$course_server}) { 10617: return 'error: invalid home server for course: '.$course_server; 10618: } 10619: # ------------------------------------------------------------- Make the course 10620: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', 10621: $course_server); 10622: unless ($reply eq 'ok') { return 'error: '.$reply; } 10623: my $uhome=&homeserver($uname,$udom,'true'); 10624: if (($uhome eq '') || ($uhome eq 'no_host')) { 10625: return 'error: no such course'; 10626: } 10627: # ----------------------------------------------------------------- Course made 10628: # log existence 10629: my $now = time; 10630: my $newcourse = { 10631: $udom.'_'.$uname => { 10632: description => $description, 10633: inst_code => $inst_code, 10634: owner => $course_owner, 10635: type => $crstype, 10636: creator => $env{'user.name'}.':'. 10637: $env{'user.domain'}, 10638: created => $now, 10639: context => $context, 10640: }, 10641: }; 10642: &courseidput($udom,$newcourse,$uhome,'notime'); 10643: # set toplevel url 10644: my $topurl=$url; 10645: unless ($nonstandard) { 10646: # ------------------------------------------ For standard courses, make top url 10647: my $mapurl=&clutter($url); 10648: if ($mapurl eq '/res/') { $mapurl=''; } 10649: $env{'form.initmap'}=(<<ENDINITMAP); 10650: <map> 10651: <resource id="1" type="start"></resource> 10652: <resource id="2" src="$mapurl"></resource> 10653: <resource id="3" type="finish"></resource> 10654: <link index="1" from="1" to="2"></link> 10655: <link index="2" from="2" to="3"></link> 10656: </map> 10657: ENDINITMAP 10658: $topurl=&declutter( 10659: &finishuserfileupload($uname,$udom,'initmap','default.sequence') 10660: ); 10661: } 10662: # ----------------------------------------------------------- Write preferences 10663: &writecoursepref($udom.'_'.$uname, 10664: ('description' => $description, 10665: 'url' => $topurl, 10666: 'internal.creator' => $env{'user.name'}.':'. 10667: $env{'user.domain'}, 10668: 'internal.created' => $now, 10669: 'internal.creationcontext' => $context) 10670: ); 10671: return '/'.$udom.'/'.$uname; 10672: } 10673: 10674: # ------------------------------------------------------------------- Create ID 10675: sub generate_coursenum { 10676: my ($udom,$crstype) = @_; 10677: my $domdesc = &domain($udom); 10678: return 'error: invalid domain' if ($domdesc eq ''); 10679: my $first; 10680: if ($crstype eq 'Community') { 10681: $first = '0'; 10682: } else { 10683: $first = int(1+rand(9)); 10684: } 10685: my $uname=$first. 10686: ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. 10687: substr($$.time,0,5).unpack("H8",pack("I32",time)). 10688: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; 10689: # ----------------------------------------------- Make sure that does not exist 10690: my $uhome=&homeserver($uname,$udom,'true'); 10691: unless (($uhome eq '') || ($uhome eq 'no_host')) { 10692: if ($crstype eq 'Community') { 10693: $first = '0'; 10694: } else { 10695: $first = int(1+rand(9)); 10696: } 10697: $uname=$first. 10698: ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. 10699: substr($$.time,0,5).unpack("H8",pack("I32",time)). 10700: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; 10701: $uhome=&homeserver($uname,$udom,'true'); 10702: unless (($uhome eq '') || ($uhome eq 'no_host')) { 10703: return 'error: unable to generate unique course-ID'; 10704: } 10705: } 10706: return $uname; 10707: } 10708: 10709: sub is_course { 10710: my ($cdom, $cnum) = scalar(@_) == 1 ? 10711: ($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; 10712: 10713: return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)); 10714: my $uhome=&homeserver($cnum,$cdom); 10715: my $iscourse; 10716: if (grep { $_ eq $uhome } current_machine_ids()) { 10717: $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum); 10718: } else { 10719: my $hashid = $cdom.':'.$cnum; 10720: ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid); 10721: unless (defined($cached)) { 10722: my %courses = &courseiddump($cdom, '.', 1, '.', '.', 10723: $cnum,undef,undef,'.'); 10724: $iscourse = 0; 10725: if (exists($courses{$cdom.'_'.$cnum})) { 10726: $iscourse = 1; 10727: } 10728: &do_cache_new('iscourse',$hashid,$iscourse,3600); 10729: } 10730: } 10731: return unless ($iscourse); 10732: return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; 10733: } 10734: 10735: sub store_userdata { 10736: my ($storehash,$datakey,$namespace,$udom,$uname) = @_; 10737: my $result; 10738: if ($datakey ne '') { 10739: if (ref($storehash) eq 'HASH') { 10740: if ($udom eq '' || $uname eq '') { 10741: $udom = $env{'user.domain'}; 10742: $uname = $env{'user.name'}; 10743: } 10744: my $uhome=&homeserver($uname,$udom); 10745: if (($uhome eq '') || ($uhome eq 'no_host')) { 10746: $result = 'error: no_host'; 10747: } else { 10748: $storehash->{'ip'} = $ENV{'REMOTE_ADDR'}; 10749: $storehash->{'host'} = $perlvar{'lonHostID'}; 10750: 10751: my $namevalue=''; 10752: foreach my $key (keys(%{$storehash})) { 10753: $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; 10754: } 10755: $namevalue=~s/\&$//; 10756: unless ($namespace eq 'courserequests') { 10757: $datakey = &escape($datakey); 10758: } 10759: $result = &reply("store:$udom:$uname:$namespace:$datakey:". 10760: $namevalue,$uhome); 10761: } 10762: } else { 10763: $result = 'error: data to store was not a hash reference'; 10764: } 10765: } else { 10766: $result= 'error: invalid requestkey'; 10767: } 10768: return $result; 10769: } 10770: 10771: # ---------------------------------------------------------- Assign Custom Role 10772: 10773: sub assigncustomrole { 10774: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_; 10775: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, 10776: $end,$start,$deleteflag,$selfenroll,$context); 10777: } 10778: 10779: # ----------------------------------------------------------------- Revoke Role 10780: 10781: sub revokerole { 10782: my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; 10783: my $now=time; 10784: return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context); 10785: } 10786: 10787: # ---------------------------------------------------------- Revoke Custom Role 10788: 10789: sub revokecustomrole { 10790: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_; 10791: my $now=time; 10792: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, 10793: $deleteflag,$selfenroll,$context); 10794: } 10795: 10796: # ------------------------------------------------------------ Disk usage 10797: sub diskusage { 10798: my ($udom,$uname,$directorypath,$getpropath)=@_; 10799: $directorypath =~ s/\/$//; 10800: my $listing=&reply('du2:'.&escape($directorypath).':' 10801: .&escape($getpropath).':'.&escape($uname).':' 10802: .&escape($udom),homeserver($uname,$udom)); 10803: if ($listing eq 'unknown_cmd') { 10804: if ($getpropath) { 10805: $directorypath = &propath($udom,$uname).'/'.$directorypath; 10806: } 10807: $listing = &reply('du:'.$directorypath,homeserver($uname,$udom)); 10808: } 10809: return $listing; 10810: } 10811: 10812: sub is_locked { 10813: my ($file_name, $domain, $user, $which) = @_; 10814: my @check; 10815: my $is_locked; 10816: push (@check,$file_name); 10817: my %locked = &get('file_permissions',\@check, 10818: $env{'user.domain'},$env{'user.name'}); 10819: my ($tmp)=keys(%locked); 10820: if ($tmp=~/^error:/) { undef(%locked); } 10821: 10822: if (ref($locked{$file_name}) eq 'ARRAY') { 10823: $is_locked = 'false'; 10824: foreach my $entry (@{$locked{$file_name}}) { 10825: if (ref($entry) eq 'ARRAY') { 10826: $is_locked = 'true'; 10827: if (ref($which) eq 'ARRAY') { 10828: push(@{$which},$entry); 10829: } else { 10830: last; 10831: } 10832: } 10833: } 10834: } else { 10835: $is_locked = 'false'; 10836: } 10837: return $is_locked; 10838: } 10839: 10840: sub declutter_portfile { 10841: my ($file) = @_; 10842: $file =~ s{^(/portfolio/|portfolio/)}{/}; 10843: return $file; 10844: } 10845: 10846: # ------------------------------------------------------------- Mark as Read Only 10847: 10848: sub mark_as_readonly { 10849: my ($domain,$user,$files,$what) = @_; 10850: my %current_permissions = &dump('file_permissions',$domain,$user); 10851: my ($tmp)=keys(%current_permissions); 10852: if ($tmp=~/^error:/) { undef(%current_permissions); } 10853: foreach my $file (@{$files}) { 10854: $file = &declutter_portfile($file); 10855: push(@{$current_permissions{$file}},$what); 10856: } 10857: &put('file_permissions',\%current_permissions,$domain,$user); 10858: return; 10859: } 10860: 10861: # ------------------------------------------------------------Save Selected Files 10862: 10863: sub save_selected_files { 10864: my ($user, $path, @files) = @_; 10865: my $filename = $user."savedfiles"; 10866: my @other_files = &files_not_in_path($user, $path); 10867: open (OUT,'>',LONCAPA::tempdir().$filename); 10868: foreach my $file (@files) { 10869: print (OUT $env{'form.currentpath'}.$file."\n"); 10870: } 10871: foreach my $file (@other_files) { 10872: print (OUT $file."\n"); 10873: } 10874: close (OUT); 10875: return 'ok'; 10876: } 10877: 10878: sub clear_selected_files { 10879: my ($user) = @_; 10880: my $filename = $user."savedfiles"; 10881: open (OUT,'>',LONCAPA::tempdir().$filename); 10882: print (OUT undef); 10883: close (OUT); 10884: return ("ok"); 10885: } 10886: 10887: sub files_in_path { 10888: my ($user, $path) = @_; 10889: my $filename = $user."savedfiles"; 10890: my %return_files; 10891: open (IN,'<',LONCAPA::tempdir().$filename); 10892: while (my $line_in = <IN>) { 10893: chomp ($line_in); 10894: my @paths_and_file = split (m!/!, $line_in); 10895: my $file_part = pop (@paths_and_file); 10896: my $path_part = join ('/', @paths_and_file); 10897: $path_part.='/'; 10898: my $path_and_file = $path_part.$file_part; 10899: if ($path_part eq $path) { 10900: $return_files{$file_part}= 'selected'; 10901: } 10902: } 10903: close (IN); 10904: return (\%return_files); 10905: } 10906: 10907: # called in portfolio select mode, to show files selected NOT in current directory 10908: sub files_not_in_path { 10909: my ($user, $path) = @_; 10910: my $filename = $user."savedfiles"; 10911: my @return_files; 10912: my $path_part; 10913: open(IN, '<',LONCAPA::tempdir().$filename); 10914: while (my $line = <IN>) { 10915: #ok, I know it's clunky, but I want it to work 10916: my @paths_and_file = split(m|/|, $line); 10917: my $file_part = pop(@paths_and_file); 10918: chomp($file_part); 10919: my $path_part = join('/', @paths_and_file); 10920: $path_part .= '/'; 10921: my $path_and_file = $path_part.$file_part; 10922: if ($path_part ne $path) { 10923: push(@return_files, ($path_and_file)); 10924: } 10925: } 10926: close(OUT); 10927: return (@return_files); 10928: } 10929: 10930: #------------------------------Submitted/Handedback Portfolio Files Versioning 10931: 10932: sub portfiles_versioning { 10933: my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_; 10934: my $portfolio_root = '/userfiles/portfolio'; 10935: return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY')); 10936: foreach my $file (@{$portfiles}) { 10937: &unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file); 10938: my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/); 10939: my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file); 10940: my $getpropath = 1; 10941: my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain, 10942: $stu_name,$getpropath); 10943: my $version = &get_next_version($answer_name,$answer_ext,$dir_list); 10944: my $new_answer = 10945: &version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version); 10946: if ($new_answer ne 'problem getting file') { 10947: push(@{$versioned_portfiles}, $directory.$new_answer); 10948: &mark_as_readonly($domain,$stu_name,[$directory.$new_answer], 10949: [$symb,$env{'request.course.id'},'graded']); 10950: } 10951: } 10952: } 10953: 10954: sub get_next_version { 10955: my ($answer_name, $answer_ext, $dir_list) = @_; 10956: my $version; 10957: if (ref($dir_list) eq 'ARRAY') { 10958: foreach my $row (@{$dir_list}) { 10959: my ($file) = split(/\&/,$row,2); 10960: my ($file_name,$file_version,$file_ext) = 10961: &file_name_version_ext($file); 10962: if (($file_name eq $answer_name) && 10963: ($file_ext eq $answer_ext)) { 10964: # gets here if filename and extension match, 10965: # regardless of version 10966: if ($file_version ne '') { 10967: # a versioned file is found so save it for later 10968: if ($file_version > $version) { 10969: $version = $file_version; 10970: } 10971: } 10972: } 10973: } 10974: } 10975: $version ++; 10976: return($version); 10977: } 10978: 10979: sub version_selected_portfile { 10980: my ($domain,$stu_name,$directory,$file_name,$version) = @_; 10981: my ($answer_name,$answer_ver,$answer_ext) = 10982: &file_name_version_ext($file_name); 10983: my $new_answer; 10984: $env{'form.copy'} = 10985: &getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name"); 10986: if($env{'form.copy'} eq '-1') { 10987: $new_answer = 'problem getting file'; 10988: } else { 10989: $new_answer = $answer_name.'.'.$version.'.'.$answer_ext; 10990: my $copy_result = 10991: &finishuserfileupload($stu_name,$domain,'copy', 10992: '/portfolio'.$directory.$new_answer); 10993: } 10994: undef($env{'form.copy'}); 10995: return ($new_answer); 10996: } 10997: 10998: sub file_name_version_ext { 10999: my ($file)=@_; 11000: my @file_parts = split(/\./, $file); 11001: my ($name,$version,$ext); 11002: if (@file_parts > 1) { 11003: $ext=pop(@file_parts); 11004: if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) { 11005: $version=pop(@file_parts); 11006: } 11007: $name=join('.',@file_parts); 11008: } else { 11009: $name=join('.',@file_parts); 11010: } 11011: return($name,$version,$ext); 11012: } 11013: 11014: #----------------------------------------------Get portfolio file permissions 11015: 11016: sub get_portfile_permissions { 11017: my ($domain,$user) = @_; 11018: my %current_permissions = &dump('file_permissions',$domain,$user); 11019: my ($tmp)=keys(%current_permissions); 11020: if ($tmp=~/^error:/) { undef(%current_permissions); } 11021: return \%current_permissions; 11022: } 11023: 11024: #---------------------------------------------Get portfolio file access controls 11025: 11026: sub get_access_controls { 11027: my ($current_permissions,$group,$file) = @_; 11028: my %access; 11029: my $real_file = $file; 11030: $file =~ s/\.meta$//; 11031: if (defined($file)) { 11032: if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') { 11033: foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) { 11034: $access{$real_file}{$control} = $$current_permissions{$file."\0".$control}; 11035: } 11036: } 11037: } else { 11038: foreach my $key (keys(%{$current_permissions})) { 11039: if ($key =~ /\0accesscontrol$/) { 11040: if (defined($group)) { 11041: if ($key !~ m-^\Q$group\E/-) { 11042: next; 11043: } 11044: } 11045: my ($fullpath) = split(/\0/,$key); 11046: if (ref($$current_permissions{$key}) eq 'HASH') { 11047: foreach my $control (keys(%{$$current_permissions{$key}})) { 11048: $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control}; 11049: } 11050: } 11051: } 11052: } 11053: } 11054: return %access; 11055: } 11056: 11057: sub modify_access_controls { 11058: my ($file_name,$changes,$domain,$user)=@_; 11059: my ($outcome,$deloutcome); 11060: my %store_permissions; 11061: my %new_values; 11062: my %new_control; 11063: my %translation; 11064: my @deletions = (); 11065: my $now = time; 11066: if (exists($$changes{'activate'})) { 11067: if (ref($$changes{'activate'}) eq 'HASH') { 11068: my @newitems = sort(keys(%{$$changes{'activate'}})); 11069: my $numnew = scalar(@newitems); 11070: for (my $i=0; $i<$numnew; $i++) { 11071: my $newkey = $newitems[$i]; 11072: my $newid = &Apache::loncommon::get_cgi_id(); 11073: if ($newkey =~ /^\d+:/) { 11074: $newkey =~ s/^(\d+)/$newid/; 11075: $translation{$1} = $newid; 11076: } elsif ($newkey =~ /^\d+_\d+_\d+:/) { 11077: $newkey =~ s/^(\d+_\d+_\d+)/$newid/; 11078: $translation{$1} = $newid; 11079: } 11080: $new_values{$file_name."\0".$newkey} = 11081: $$changes{'activate'}{$newitems[$i]}; 11082: $new_control{$newkey} = $now; 11083: } 11084: } 11085: } 11086: my %todelete; 11087: my %changed_items; 11088: foreach my $action ('delete','update') { 11089: if (exists($$changes{$action})) { 11090: if (ref($$changes{$action}) eq 'HASH') { 11091: foreach my $key (keys(%{$$changes{$action}})) { 11092: my ($itemnum) = ($key =~ /^([^:]+):/); 11093: if ($action eq 'delete') { 11094: $todelete{$itemnum} = 1; 11095: } else { 11096: $changed_items{$itemnum} = $key; 11097: } 11098: } 11099: } 11100: } 11101: } 11102: # get lock on access controls for file. 11103: my $lockhash = { 11104: $file_name."\0".'locked_access_records' => $env{'user.name'}. 11105: ':'.$env{'user.domain'}, 11106: }; 11107: my $tries = 0; 11108: my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); 11109: 11110: while (($gotlock ne 'ok') && $tries < 10) { 11111: $tries ++; 11112: sleep(0.1); 11113: $gotlock = &newput('file_permissions',$lockhash,$domain,$user); 11114: } 11115: if ($gotlock eq 'ok') { 11116: my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name); 11117: my ($tmp)=keys(%curr_permissions); 11118: if ($tmp=~/^error:/) { undef(%curr_permissions); } 11119: if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) { 11120: my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'}; 11121: if (ref($curr_controls) eq 'HASH') { 11122: foreach my $control_item (keys(%{$curr_controls})) { 11123: my ($itemnum) = ($control_item =~ /^([^:]+):/); 11124: if (defined($todelete{$itemnum})) { 11125: push(@deletions,$file_name."\0".$control_item); 11126: } else { 11127: if (defined($changed_items{$itemnum})) { 11128: $new_control{$changed_items{$itemnum}} = $now; 11129: push(@deletions,$file_name."\0".$control_item); 11130: $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}}; 11131: } else { 11132: $new_control{$control_item} = $$curr_controls{$control_item}; 11133: } 11134: } 11135: } 11136: } 11137: } 11138: my ($group); 11139: if (&is_course($domain,$user)) { 11140: ($group,my $file) = split(/\//,$file_name,2); 11141: } 11142: $deloutcome = &del('file_permissions',\@deletions,$domain,$user); 11143: $new_values{$file_name."\0".'accesscontrol'} = \%new_control; 11144: $outcome = &put('file_permissions',\%new_values,$domain,$user); 11145: # remove lock 11146: my @del_lock = ($file_name."\0".'locked_access_records'); 11147: my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); 11148: my $sqlresult = 11149: &update_portfolio_table($user,$domain,$file_name,'portfolio_access', 11150: $group); 11151: } else { 11152: $outcome = "error: could not obtain lockfile\n"; 11153: } 11154: return ($outcome,$deloutcome,\%new_values,\%translation); 11155: } 11156: 11157: sub make_public_indefinitely { 11158: my (@requrl) = @_; 11159: return &automated_portfile_access('public',\@requrl); 11160: } 11161: 11162: sub automated_portfile_access { 11163: my ($accesstype,$addsref,$delsref,$info) = @_; 11164: unless (($accesstype eq 'public') || ($accesstype eq 'ip')) { 11165: return 'invalid'; 11166: } 11167: my %urls; 11168: if (ref($addsref) eq 'ARRAY') { 11169: foreach my $requrl (@{$addsref}) { 11170: if (&is_portfolio_url($requrl)) { 11171: unless (exists($urls{$requrl})) { 11172: $urls{$requrl} = 'add'; 11173: } 11174: } 11175: } 11176: } 11177: if (ref($delsref) eq 'ARRAY') { 11178: foreach my $requrl (@{$delsref}) { 11179: if (&is_portfolio_url($requrl)) { 11180: unless (exists($urls{$requrl})) { 11181: $urls{$requrl} = 'delete'; 11182: } 11183: } 11184: } 11185: } 11186: unless (keys(%urls)) { 11187: return 'invalid'; 11188: } 11189: my $ip; 11190: if ($accesstype eq 'ip') { 11191: if (ref($info) eq 'HASH') { 11192: if ($info->{'ip'} ne '') { 11193: $ip = $info->{'ip'}; 11194: } 11195: } 11196: if ($ip eq '') { 11197: return 'invalid'; 11198: } 11199: } 11200: my $errors; 11201: my $now = time; 11202: my %current_perms; 11203: foreach my $requrl (sort(keys(%urls))) { 11204: my $action; 11205: if ($urls{$requrl} eq 'add') { 11206: $action = 'activate'; 11207: } else { 11208: $action = 'none'; 11209: } 11210: my $aclnum = 0; 11211: my (undef,$udom,$unum,$file_name,$group) = 11212: &parse_portfolio_url($requrl); 11213: unless (exists($current_perms{$unum.':'.$udom})) { 11214: $current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum); 11215: } 11216: my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom}, 11217: $group,$file_name); 11218: foreach my $key (keys(%{$access_controls{$file_name}})) { 11219: my ($num,$scope,$end,$start) = 11220: ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); 11221: if ($scope eq $accesstype) { 11222: if (($start <= $now) && ($end == 0)) { 11223: if ($accesstype eq 'ip') { 11224: if (ref($access_controls{$file_name}{$key}) eq 'HASH') { 11225: if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') { 11226: if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) { 11227: if ($urls{$requrl} eq 'add') { 11228: $action = 'none'; 11229: last; 11230: } else { 11231: $action = 'delete'; 11232: $aclnum = $num; 11233: last; 11234: } 11235: } 11236: } 11237: } 11238: } elsif ($accesstype eq 'public') { 11239: if ($urls{$requrl} eq 'add') { 11240: $action = 'none'; 11241: last; 11242: } else { 11243: $action = 'delete'; 11244: $aclnum = $num; 11245: last; 11246: } 11247: } 11248: } elsif ($accesstype eq 'public') { 11249: $action = 'update'; 11250: $aclnum = $num; 11251: last; 11252: } 11253: } 11254: } 11255: if ($action eq 'none') { 11256: next; 11257: } else { 11258: my %changes; 11259: my $newend = 0; 11260: my $newstart = $now; 11261: my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart; 11262: $changes{$action}{$newkey} = { 11263: type => $accesstype, 11264: time => { 11265: start => $newstart, 11266: end => $newend, 11267: }, 11268: }; 11269: if ($accesstype eq 'ip') { 11270: $changes{$action}{$newkey}{'ip'} = [$ip]; 11271: } 11272: my ($outcome,$deloutcome,$new_values,$translation) = 11273: &modify_access_controls($file_name,\%changes,$udom,$unum); 11274: unless ($outcome eq 'ok') { 11275: $errors .= $outcome.' '; 11276: } 11277: } 11278: } 11279: if ($errors) { 11280: $errors =~ s/\s$//; 11281: return $errors; 11282: } else { 11283: return 'ok'; 11284: } 11285: } 11286: 11287: #------------------------------------------------------Get Marked as Read Only 11288: 11289: sub get_marked_as_readonly { 11290: my ($domain,$user,$what,$group) = @_; 11291: my $current_permissions = &get_portfile_permissions($domain,$user); 11292: my @readonly_files; 11293: my $cmp1=$what; 11294: if (ref($what)) { $cmp1=join('',@{$what}) }; 11295: while (my ($file_name,$value) = each(%{$current_permissions})) { 11296: if (defined($group)) { 11297: if ($file_name !~ m-^\Q$group\E/-) { 11298: next; 11299: } 11300: } 11301: if (ref($value) eq "ARRAY"){ 11302: foreach my $stored_what (@{$value}) { 11303: my $cmp2=$stored_what; 11304: if (ref($stored_what) eq 'ARRAY') { 11305: $cmp2=join('',@{$stored_what}); 11306: } 11307: if ($cmp1 eq $cmp2) { 11308: push(@readonly_files, $file_name); 11309: last; 11310: } elsif (!defined($what)) { 11311: push(@readonly_files, $file_name); 11312: last; 11313: } 11314: } 11315: } 11316: } 11317: return @readonly_files; 11318: } 11319: #-----------------------------------------------------------Get Marked as Read Only Hash 11320: 11321: sub get_marked_as_readonly_hash { 11322: my ($current_permissions,$group,$what) = @_; 11323: my %readonly_files; 11324: while (my ($file_name,$value) = each(%{$current_permissions})) { 11325: if (defined($group)) { 11326: if ($file_name !~ m-^\Q$group\E/-) { 11327: next; 11328: } 11329: } 11330: if (ref($value) eq "ARRAY"){ 11331: foreach my $stored_what (@{$value}) { 11332: if (ref($stored_what) eq 'ARRAY') { 11333: foreach my $lock_descriptor(@{$stored_what}) { 11334: if ($lock_descriptor eq 'graded') { 11335: $readonly_files{$file_name} = 'graded'; 11336: } elsif ($lock_descriptor eq 'handback') { 11337: $readonly_files{$file_name} = 'handback'; 11338: } else { 11339: if (!exists($readonly_files{$file_name})) { 11340: $readonly_files{$file_name} = 'locked'; 11341: } 11342: } 11343: } 11344: } 11345: } 11346: } 11347: } 11348: return %readonly_files; 11349: } 11350: # ------------------------------------------------------------ Unmark as Read Only 11351: 11352: sub unmark_as_readonly { 11353: # unmarks $file_name (if $file_name is defined), or all files locked by $what 11354: # for portfolio submissions, $what contains [$symb,$crsid] 11355: my ($domain,$user,$what,$file_name,$group) = @_; 11356: $file_name = &declutter_portfile($file_name); 11357: my $symb_crs = $what; 11358: if (ref($what)) { $symb_crs=join('',@$what); } 11359: my %current_permissions = &dump('file_permissions',$domain,$user,$group); 11360: my ($tmp)=keys(%current_permissions); 11361: if ($tmp=~/^error:/) { undef(%current_permissions); } 11362: my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group); 11363: foreach my $file (@readonly_files) { 11364: my $clean_file = &declutter_portfile($file); 11365: if (defined($file_name) && ($file_name ne $clean_file)) { next; } 11366: my $current_locks = $current_permissions{$file}; 11367: my @new_locks; 11368: my @del_keys; 11369: if (ref($current_locks) eq "ARRAY"){ 11370: foreach my $locker (@{$current_locks}) { 11371: my $compare=$locker; 11372: if (ref($locker) eq 'ARRAY') { 11373: $compare=join('',@{$locker}); 11374: if ($compare ne $symb_crs) { 11375: push(@new_locks, $locker); 11376: } 11377: } 11378: } 11379: if (scalar(@new_locks) > 0) { 11380: $current_permissions{$file} = \@new_locks; 11381: } else { 11382: push(@del_keys, $file); 11383: &del('file_permissions',\@del_keys, $domain, $user); 11384: delete($current_permissions{$file}); 11385: } 11386: } 11387: } 11388: &put('file_permissions',\%current_permissions,$domain,$user); 11389: return; 11390: } 11391: 11392: # ------------------------------------------------------------ Directory lister 11393: 11394: sub dirlist { 11395: my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_; 11396: $uri=~s/^\///; 11397: $uri=~s/\/$//; 11398: my ($udom, $uname); 11399: if ($getuserdir) { 11400: $udom = $userdomain; 11401: $uname = $username; 11402: } else { 11403: (undef,$udom,$uname)=split(/\//,$uri); 11404: if(defined($userdomain)) { 11405: $udom = $userdomain; 11406: } 11407: if(defined($username)) { 11408: $uname = $username; 11409: } 11410: } 11411: my ($dirRoot,$listing,@listing_results); 11412: 11413: $dirRoot = $perlvar{'lonDocRoot'}; 11414: if (defined($getpropath)) { 11415: $dirRoot = &propath($udom,$uname); 11416: $dirRoot =~ s/\/$//; 11417: } elsif (defined($getuserdir)) { 11418: my $subdir=$uname.'__'; 11419: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 11420: $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'} 11421: ."/$udom/$subdir/$uname"; 11422: } elsif (defined($alternateRoot)) { 11423: $dirRoot = $alternateRoot; 11424: } 11425: 11426: if($udom) { 11427: if($uname) { 11428: my $uhome = &homeserver($uname,$udom); 11429: if ($uhome eq 'no_host') { 11430: return ([],'no_host'); 11431: } 11432: $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' 11433: .$getuserdir.':'.&escape($dirRoot) 11434: .':'.&escape($uname).':'.&escape($udom),$uhome); 11435: if ($listing eq 'unknown_cmd') { 11436: $listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome); 11437: } else { 11438: @listing_results = map { &unescape($_); } split(/:/,$listing); 11439: } 11440: if ($listing eq 'unknown_cmd') { 11441: $listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome); 11442: @listing_results = split(/:/,$listing); 11443: } else { 11444: @listing_results = map { &unescape($_); } split(/:/,$listing); 11445: } 11446: if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || 11447: ($listing eq 'rejected') || ($listing eq 'refused') || 11448: ($listing eq 'no_such_dir') || ($listing eq 'empty')) { 11449: return ([],$listing); 11450: } else { 11451: return (\@listing_results); 11452: } 11453: } elsif(!$alternateRoot) { 11454: my (%allusers,%listerror); 11455: my %servers = &get_servers($udom,'library'); 11456: foreach my $tryserver (keys(%servers)) { 11457: $listing = &reply('ls3:'.&escape("/res/$udom").':::::'. 11458: &escape($udom),$tryserver); 11459: if ($listing eq 'unknown_cmd') { 11460: $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. 11461: $udom, $tryserver); 11462: } else { 11463: @listing_results = map { &unescape($_); } split(/:/,$listing); 11464: } 11465: if ($listing eq 'unknown_cmd') { 11466: $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. 11467: $udom, $tryserver); 11468: @listing_results = split(/:/,$listing); 11469: } else { 11470: @listing_results = 11471: map { &unescape($_); } split(/:/,$listing); 11472: } 11473: if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || 11474: ($listing eq 'rejected') || ($listing eq 'refused') || 11475: ($listing eq 'no_such_dir') || ($listing eq 'empty')) { 11476: $listerror{$tryserver} = $listing; 11477: } else { 11478: foreach my $line (@listing_results) { 11479: my ($entry) = split(/&/,$line,2); 11480: $allusers{$entry} = 1; 11481: } 11482: } 11483: } 11484: my @alluserslist=(); 11485: foreach my $user (sort(keys(%allusers))) { 11486: push(@alluserslist,$user.'&user'); 11487: } 11488: 11489: if (!%listerror) { 11490: # no errors 11491: return (\@alluserslist); 11492: } elsif (scalar(keys(%servers)) == 1) { 11493: # one library server, one error 11494: my ($key) = keys(%listerror); 11495: return (\@alluserslist, $listerror{$key}); 11496: } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) { 11497: # con_lost indicates that we might miss data from at least one 11498: # library server 11499: return (\@alluserslist, 'con_lost'); 11500: } else { 11501: # multiple library servers and no con_lost -> data should be 11502: # complete. 11503: return (\@alluserslist); 11504: } 11505: 11506: } else { 11507: return ([],'missing username'); 11508: } 11509: } elsif(!defined($getpropath)) { 11510: my $path = $perlvar{'lonDocRoot'}.'/res/'; 11511: my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains())); 11512: return (\@all_domains); 11513: } else { 11514: return ([],'missing domain'); 11515: } 11516: } 11517: 11518: # --------------------------------------------- GetFileTimestamp 11519: # This function utilizes dirlist and returns the date stamp for 11520: # when it was last modified. It will also return an error of -1 11521: # if an error occurs 11522: 11523: sub GetFileTimestamp { 11524: my ($studentDomain,$studentName,$filename,$getuserdir)=@_; 11525: $studentDomain = &LONCAPA::clean_domain($studentDomain); 11526: $studentName = &LONCAPA::clean_username($studentName); 11527: my ($fileref,$error) = &dirlist($filename,$studentDomain,$studentName, 11528: undef,$getuserdir); 11529: if (($error eq 'empty') || ($error eq 'no_such_dir')) { 11530: return -1; 11531: } 11532: if (ref($fileref) eq 'ARRAY') { 11533: my @stats = split('&',$fileref->[0]); 11534: # @stats contains first the filename, then the stat output 11535: return $stats[10]; # so this is 10 instead of 9. 11536: } else { 11537: return -1; 11538: } 11539: } 11540: 11541: sub stat_file { 11542: my ($uri) = @_; 11543: $uri = &clutter_with_no_wrapper($uri); 11544: 11545: my ($udom,$uname,$file); 11546: if ($uri =~ m-^/(uploaded|editupload)/-) { 11547: ($udom,$uname,$file) = 11548: ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); 11549: $file = 'userfiles/'.$file; 11550: } 11551: if ($uri =~ m-^/res/-) { 11552: ($udom,$uname) = 11553: ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-); 11554: $file = $uri; 11555: } 11556: 11557: if (!$udom || !$uname || !$file) { 11558: # unable to handle the uri 11559: return (); 11560: } 11561: my $getpropath; 11562: if ($file =~ /^userfiles\//) { 11563: $getpropath = 1; 11564: } 11565: my ($listref,$error) = &dirlist($file,$udom,$uname,$getpropath); 11566: if (($error eq 'empty') || ($error eq 'no_such_dir')) { 11567: return (); 11568: } else { 11569: if (ref($listref) eq 'ARRAY') { 11570: my @stats = split('&',$listref->[0]); 11571: shift(@stats); #filename is first 11572: return @stats; 11573: } 11574: } 11575: return (); 11576: } 11577: 11578: # --------------------------------------------------------- recursedirs 11579: # Recursive function to traverse either a specific user's Authoring Space 11580: # or corresponding Published Resource Space, and populate the hash ref: 11581: # $dirhashref with URLs of all directories, and if $filehashref hash 11582: # ref arg is provided, the URLs of any files, excluding versioned, .meta, 11583: # or .rights files in resource space, and .meta, .save, .log, and .bak 11584: # files in Authoring Space. 11585: # 11586: # Inputs: 11587: # 11588: # $is_home - true if current server is home server for user's space 11589: # $context - either: priv, or res respectively for Authoring or Resource Space. 11590: # $docroot - Document root (i.e., /home/httpd/html 11591: # $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname 11592: # $relpath - Current path (relative to top level). 11593: # $dirhashref - reference to hash to populate with URLs of directories (Required) 11594: # $filehashref - reference to hash to populate with URLs of files (Optional) 11595: # 11596: # Returns: nothing 11597: # 11598: # Side Effects: populates $dirhashref, and $filehashref (if provided). 11599: # 11600: # Currently used by interface/londocs.pm to create linked select boxes for 11601: # directory and filename to import a Course "Author" resource into a course, and 11602: # also to create linked select boxes for Authoring Space and Directory to choose 11603: # save location for creation of a new "standard" problem from the Course Editor. 11604: # 11605: 11606: sub recursedirs { 11607: my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_; 11608: return unless (ref($dirhashref) eq 'HASH'); 11609: my $currpath = $docroot.$toppath; 11610: if ($relpath) { 11611: $currpath .= "/$relpath"; 11612: } 11613: my $savefile; 11614: if (ref($filehashref)) { 11615: $savefile = 1; 11616: } 11617: if ($is_home) { 11618: if (opendir(my $dirh,$currpath)) { 11619: foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) { 11620: next if ($item eq ''); 11621: if (-d "$currpath/$item") { 11622: my $newpath; 11623: if ($relpath) { 11624: $newpath = "$relpath/$item"; 11625: } else { 11626: $newpath = $item; 11627: } 11628: $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; 11629: &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); 11630: } elsif ($savefile) { 11631: if ($context eq 'priv') { 11632: unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { 11633: $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; 11634: } 11635: } else { 11636: unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) { 11637: $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; 11638: } 11639: } 11640: } 11641: } 11642: closedir($dirh); 11643: } 11644: } else { 11645: my ($dirlistref,$listerror) = 11646: &dirlist($toppath.$relpath); 11647: my @dir_lines; 11648: my $dirptr=16384; 11649: if (ref($dirlistref) eq 'ARRAY') { 11650: foreach my $dir_line (sort 11651: { 11652: my ($afile)=split('&',$a,2); 11653: my ($bfile)=split('&',$b,2); 11654: return (lc($afile) cmp lc($bfile)); 11655: } (@{$dirlistref})) { 11656: my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) = 11657: split(/\&/,$dir_line,16); 11658: $item =~ s/\s+$//; 11659: next if (($item =~ /^\.\.?$/) || ($obs)); 11660: if ($dirptr&$testdir) { 11661: my $newpath; 11662: if ($relpath) { 11663: $newpath = "$relpath/$item"; 11664: } else { 11665: $relpath = '/'; 11666: $newpath = $item; 11667: } 11668: $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; 11669: &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); 11670: } elsif ($savefile) { 11671: if ($context eq 'priv') { 11672: unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { 11673: $filehashref->{$relpath}{$item} = 1; 11674: } 11675: } else { 11676: unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) { 11677: $filehashref->{$relpath}{$item} = 1; 11678: } 11679: } 11680: } 11681: } 11682: } 11683: } 11684: return; 11685: } 11686: 11687: # -------------------------------------------------------- Value of a Condition 11688: 11689: # gets the value of a specific preevaluated condition 11690: # stored in the string $env{user.state.<cid>} 11691: # or looks up a condition reference in the bighash and if if hasn't 11692: # already been evaluated recurses into docondval to get the value of 11693: # the condition, then memoizing it to 11694: # $env{user.state.<cid>.<condition>} 11695: sub directcondval { 11696: my $number=shift; 11697: if (!defined($env{'user.state.'.$env{'request.course.id'}})) { 11698: &Apache::lonuserstate::evalstate(); 11699: } 11700: if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) { 11701: return $env{'user.state.'.$env{'request.course.id'}.".$number"}; 11702: } elsif ($number =~ /^_/) { 11703: my $sub_condition; 11704: if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db', 11705: &GDBM_READER(),0640)) { 11706: $sub_condition=$bighash{'conditions'.$number}; 11707: untie(%bighash); 11708: } 11709: my $value = &docondval($sub_condition); 11710: &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value}); 11711: return $value; 11712: } 11713: if ($env{'user.state.'.$env{'request.course.id'}}) { 11714: return substr($env{'user.state.'.$env{'request.course.id'}},$number,1); 11715: } else { 11716: return 2; 11717: } 11718: } 11719: 11720: # get the collection of conditions for this resource 11721: sub condval { 11722: my $condidx=shift; 11723: my $allpathcond=''; 11724: foreach my $cond (split(/\|/,$condidx)) { 11725: if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) { 11726: $allpathcond.= 11727: '('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')|'; 11728: } 11729: } 11730: $allpathcond=~s/\|$//; 11731: return &docondval($allpathcond); 11732: } 11733: 11734: #evaluates an expression of conditions 11735: sub docondval { 11736: my ($allpathcond) = @_; 11737: my $result=0; 11738: if ($env{'request.course.id'} 11739: && defined($allpathcond)) { 11740: my $operand='|'; 11741: my @stack; 11742: foreach my $chunk ($allpathcond=~/(\d+|_\d+\.\d+|$|$|\&|\|)/g) { 11743: if ($chunk eq '(') { 11744: push @stack,($operand,$result); 11745: } elsif ($chunk eq ')') { 11746: my $before=pop @stack; 11747: if (pop @stack eq '&') { 11748: $result=$result>$before?$before:$result; 11749: } else { 11750: $result=$result>$before?$result:$before; 11751: } 11752: } elsif (($chunk eq '&') || ($chunk eq '|')) { 11753: $operand=$chunk; 11754: } else { 11755: my $new=directcondval($chunk); 11756: if ($operand eq '&') { 11757: $result=$result>$new?$new:$result; 11758: } else { 11759: $result=$result>$new?$result:$new; 11760: } 11761: } 11762: } 11763: } 11764: return $result; 11765: } 11766: 11767: # ---------------------------------------------------- Devalidate courseresdata 11768: 11769: sub devalidatecourseresdata { 11770: my ($coursenum,$coursedomain)=@_; 11771: my $hashid=$coursenum.':'.$coursedomain; 11772: &devalidate_cache_new('courseres',$hashid); 11773: } 11774: 11775: 11776: # --------------------------------------------------- Course Resourcedata Query 11777: # 11778: # Parameters: 11779: # $coursenum - Number of the course. 11780: # $coursedomain - Domain at which the course was created. 11781: # Returns: 11782: # A hash of the course parameters along (I think) with timestamps 11783: # and version info. 11784: 11785: sub get_courseresdata { 11786: my ($coursenum,$coursedomain)=@_; 11787: my $coursehom=&homeserver($coursenum,$coursedomain); 11788: my $hashid=$coursenum.':'.$coursedomain; 11789: my ($result,$cached)=&is_cached_new('courseres',$hashid); 11790: my %dumpreply; 11791: unless (defined($cached)) { 11792: %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); 11793: $result=\%dumpreply; 11794: my ($tmp) = keys(%dumpreply); 11795: if ($tmp !~ /^(con_lost|error|no_such_host)/i) { 11796: &do_cache_new('courseres',$hashid,$result,600); 11797: } elsif ($tmp =~ /^(con_lost|no_such_host)/) { 11798: return $tmp; 11799: } elsif ($tmp =~ /^(error)/) { 11800: $result=undef; 11801: &do_cache_new('courseres',$hashid,$result,600); 11802: } 11803: } 11804: return $result; 11805: } 11806: 11807: sub devalidateuserresdata { 11808: my ($uname,$udom)=@_; 11809: my $hashid="$udom:$uname"; 11810: &devalidate_cache_new('userres',$hashid); 11811: } 11812: 11813: sub get_userresdata { 11814: my ($uname,$udom)=@_; 11815: #most student don\'t have any data set, check if there is some data 11816: if (&EXT_cache_status($udom,$uname)) { return undef; } 11817: 11818: my $hashid="$udom:$uname"; 11819: my ($result,$cached)=&is_cached_new('userres',$hashid); 11820: if (!defined($cached)) { 11821: my %resourcedata=&dump('resourcedata',$udom,$uname); 11822: $result=\%resourcedata; 11823: &do_cache_new('userres',$hashid,$result,600); 11824: } 11825: my ($tmp)=keys(%$result); 11826: if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { 11827: return $result; 11828: } 11829: #error 2 occurs when the .db doesn't exist 11830: if ($tmp!~/error: 2 /) { 11831: if ((!defined($cached)) || ($tmp ne 'con_lost')) { 11832: &logthis("WARNING:". 11833: " Trying to get resource data for ". 11834: $uname." at ".$udom.": ". 11835: $tmp.""); 11836: } 11837: } elsif ($tmp=~/error: 2 /) { 11838: #&EXT_cache_set($udom,$uname); 11839: &do_cache_new('userres',$hashid,undef,600); 11840: undef($tmp); # not really an error so don't send it back 11841: } 11842: return $tmp; 11843: } 11844: #----------------------------------------------- resdata - return resource data 11845: # Purpose: 11846: # Return resource data for either users or for a course. 11847: # Parameters: 11848: # $name - Course/user name. 11849: # $domain - Name of the domain the user/course is registered on. 11850: # $type - Type of thing $name is (must be 'course' or 'user') 11851: # $mapp - decluttered URL of enclosing map 11852: # $recursed - Ref to scalar -- set to 1, if nested maps have been recursed. 11853: # $recurseup - Ref to array of map URLs, starting with map containing 11854: # $mapp up through hierarchy of nested maps to top level map. 11855: # $courseid - CourseID (first part of param identifier). 11856: # $modifier - Middle part of param identifier. 11857: # $what - Last part of param identifier. 11858: # @which - Array of names of resources desired. 11859: # Returns: 11860: # The value of the first reasource in @which that is found in the 11861: # resource hash. 11862: # Exceptional Conditions: 11863: # If the $type passed in is not valid (not the string 'course' or 11864: # 'user', an undefined reference is returned. 11865: # If none of the resources are found, an undef is returned 11866: sub resdata { 11867: my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid, 11868: $modifier,$what,@which)=@_; 11869: my $result; 11870: if ($type eq 'course') { 11871: $result=&get_courseresdata($name,$domain); 11872: } elsif ($type eq 'user') { 11873: $result=&get_userresdata($name,$domain); 11874: } 11875: if (!ref($result)) { return $result; } 11876: foreach my $item (@which) { 11877: if ($item->[1] eq 'course') { 11878: if ((ref($recurseup) eq 'ARRAY') && (ref($recursed) eq 'SCALAR')) { 11879: unless ($$recursed) { 11880: @{$recurseup} = &get_map_hierarchy($mapp,$courseid); 11881: $$recursed = 1; 11882: } 11883: foreach my $item (@${recurseup}) { 11884: my $norecursechk=$courseid.$modifier.$item.'___(all).'.$what; 11885: last if (defined($result->{$norecursechk})); 11886: my $recursechk=$courseid.$modifier.$item.'___(rec).'.$what; 11887: if (defined($result->{$recursechk})) { return [$result->{$recursechk},'map']; } 11888: } 11889: } 11890: } 11891: if (defined($result->{$item->[0]})) { 11892: return [$result->{$item->[0]},$item->[1]]; 11893: } 11894: } 11895: return undef; 11896: } 11897: 11898: sub get_domain_lti { 11899: my ($cdom,$context) = @_; 11900: my ($name,%lti); 11901: if ($context eq 'consumer') { 11902: $name = 'ltitools'; 11903: } elsif ($context eq 'provider') { 11904: $name = 'lti'; 11905: } else { 11906: return %lti; 11907: } 11908: my ($result,$cached)=&is_cached_new($name,$cdom); 11909: if (defined($cached)) { 11910: if (ref($result) eq 'HASH') { 11911: %lti = %{$result}; 11912: } 11913: } else { 11914: my %domconfig = &get_dom('configuration',[$name],$cdom); 11915: if (ref($domconfig{$name}) eq 'HASH') { 11916: %lti = %{$domconfig{$name}}; 11917: my %encdomconfig = &get_dom('encconfig',[$name],$cdom); 11918: if (ref($encdomconfig{$name}) eq 'HASH') { 11919: foreach my $id (keys(%lti)) { 11920: if (ref($encdomconfig{$name}{$id}) eq 'HASH') { 11921: foreach my $item ('key','secret') { 11922: $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item}; 11923: } 11924: } 11925: } 11926: } 11927: } 11928: my $cachetime = 24*60*60; 11929: &do_cache_new($name,$cdom,\%lti,$cachetime); 11930: } 11931: return %lti; 11932: } 11933: 11934: sub get_numsuppfiles { 11935: my ($cnum,$cdom,$ignorecache)=@_; 11936: my $hashid=$cnum.':'.$cdom; 11937: my ($suppcount,$cached); 11938: unless ($ignorecache) { 11939: ($suppcount,$cached) = &is_cached_new('suppcount',$hashid); 11940: } 11941: unless (defined($cached)) { 11942: my $chome=&homeserver($cnum,$cdom); 11943: unless ($chome eq 'no_host') { 11944: ($suppcount,my $supptools,my $errors) = (0,0,0); 11945: my $suppmap = 'supplemental.sequence'; 11946: ($suppcount,$supptools,$errors) = 11947: &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount, 11948: $supptools,$errors); 11949: } 11950: &do_cache_new('suppcount',$hashid,$suppcount,600); 11951: } 11952: return $suppcount; 11953: } 11954: 11955: # 11956: # EXT resource caching routines 11957: # 11958: 11959: { 11960: # Cache (5 seconds) of map hierarchy for speedup of navmaps display 11961: # 11962: # The course for which we cache 11963: my $cachedmapkey=''; 11964: # The cached recursive maps for this course 11965: my %cachedmaps=(); 11966: # When this was last done 11967: my $cachedmaptime=''; 11968: 11969: sub clear_EXT_cache_status { 11970: &delenv('cache.EXT.'); 11971: } 11972: 11973: sub EXT_cache_status { 11974: my ($target_domain,$target_user) = @_; 11975: my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; 11976: if (exists($env{$cachename}) && ($env{$cachename}+600) > time) { 11977: # We know already the user has no data 11978: return 1; 11979: } else { 11980: return 0; 11981: } 11982: } 11983: 11984: sub EXT_cache_set { 11985: my ($target_domain,$target_user) = @_; 11986: my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; 11987: #&appenv({$cachename => time}); 11988: } 11989: 11990: # --------------------------------------------------------- Value of a Variable 11991: sub EXT { 11992: 11993: my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_; 11994: unless ($varname) { return ''; } 11995: #get real user name/domain, courseid and symb 11996: my $courseid; 11997: my $publicuser; 11998: if ($symbparm) { 11999: $symbparm=&get_symb_from_alias($symbparm); 12000: } 12001: if (!($uname && $udom)) { 12002: (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm); 12003: if (!$symbparm) { $symbparm=$cursymb; } 12004: } else { 12005: $courseid=$env{'request.course.id'}; 12006: } 12007: my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); 12008: my $rest; 12009: if (defined($therest[0])) { 12010: $rest=join('.',@therest); 12011: } else { 12012: $rest=''; 12013: } 12014: 12015: my $qualifierrest=$qualifier; 12016: if ($rest) { $qualifierrest.='.'.$rest; } 12017: my $spacequalifierrest=$space; 12018: if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } 12019: if ($realm eq 'user') { 12020: # --------------------------------------------------------------- user.resource 12021: if ($space eq 'resource') { 12022: if ( (defined($Apache::lonhomework::parsing_a_problem) 12023: || defined($Apache::lonhomework::parsing_a_task)) 12024: && 12025: ($symbparm eq &symbread()) ) { 12026: # if we are in the middle of processing the resource the 12027: # get the value we are planning on committing 12028: if (defined($Apache::lonhomework::results{$qualifierrest})) { 12029: return $Apache::lonhomework::results{$qualifierrest}; 12030: } else { 12031: return $Apache::lonhomework::history{$qualifierrest}; 12032: } 12033: } else { 12034: my %restored; 12035: if ($publicuser || $env{'request.state'} eq 'construct') { 12036: %restored=&tmprestore($symbparm,$courseid,$udom,$uname); 12037: } else { 12038: %restored=&restore($symbparm,$courseid,$udom,$uname); 12039: } 12040: return $restored{$qualifierrest}; 12041: } 12042: # ----------------------------------------------------------------- user.access 12043: } elsif ($space eq 'access') { 12044: # FIXME - not supporting calls for a specific user 12045: return &allowed($qualifier,$rest); 12046: # ------------------------------------------ user.preferences, user.environment 12047: } elsif (($space eq 'preferences') || ($space eq 'environment')) { 12048: if (($uname eq $env{'user.name'}) && 12049: ($udom eq $env{'user.domain'})) { 12050: return $env{join('.',('environment',$qualifierrest))}; 12051: } else { 12052: my %returnhash; 12053: if (!$publicuser) { 12054: %returnhash=&userenvironment($udom,$uname, 12055: $qualifierrest); 12056: } 12057: return $returnhash{$qualifierrest}; 12058: } 12059: # ----------------------------------------------------------------- user.course 12060: } elsif ($space eq 'course') { 12061: # FIXME - not supporting calls for a specific user 12062: return $env{join('.',('request.course',$qualifier))}; 12063: # ------------------------------------------------------------------- user.role 12064: } elsif ($space eq 'role') { 12065: # FIXME - not supporting calls for a specific user 12066: my ($role,$where)=split(/\./,$env{'request.role'}); 12067: if ($qualifier eq 'value') { 12068: return $role; 12069: } elsif ($qualifier eq 'extent') { 12070: return $where; 12071: } 12072: # ----------------------------------------------------------------- user.domain 12073: } elsif ($space eq 'domain') { 12074: return $udom; 12075: # ------------------------------------------------------------------- user.name 12076: } elsif ($space eq 'name') { 12077: return $uname; 12078: # ---------------------------------------------------- Any other user namespace 12079: } else { 12080: my %reply; 12081: if (!$publicuser) { 12082: %reply=&get($space,[$qualifierrest],$udom,$uname); 12083: } 12084: return $reply{$qualifierrest}; 12085: } 12086: } elsif ($realm eq 'query') { 12087: # ---------------------------------------------- pull stuff out of query string 12088: &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, 12089: [$spacequalifierrest]); 12090: return $env{'form.'.$spacequalifierrest}; 12091: } elsif ($realm eq 'request') { 12092: # ------------------------------------------------------------- request.browser 12093: if ($space eq 'browser') { 12094: return $env{'browser.'.$qualifier}; 12095: # ------------------------------------------------------------ request.filename 12096: } else { 12097: return $env{'request.'.$spacequalifierrest}; 12098: } 12099: } elsif ($realm eq 'course') { 12100: # ---------------------------------------------------------- course.description 12101: return $env{'course.'.$courseid.'.'.$spacequalifierrest}; 12102: } elsif ($realm eq 'resource') { 12103: 12104: if (defined($courseid) && $courseid eq $env{'request.course.id'}) { 12105: if (!$symbparm) { $symbparm=&symbread(); } 12106: } 12107: 12108: if ($qualifier eq '') { 12109: if ($space eq 'title') { 12110: if (!$symbparm) { $symbparm = $env{'request.filename'}; } 12111: return &gettitle($symbparm); 12112: } 12113: 12114: if ($space eq 'map') { 12115: my ($map) = &decode_symb($symbparm); 12116: return &symbread($map); 12117: } 12118: if ($space eq 'maptitle') { 12119: my ($map) = &decode_symb($symbparm); 12120: return &gettitle($map); 12121: } 12122: if ($space eq 'filename') { 12123: if ($symbparm) { 12124: return &clutter((&decode_symb($symbparm))[2]); 12125: } 12126: return &hreflocation('',$env{'request.filename'}); 12127: } 12128: 12129: if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) { 12130: if ($space eq 'visibleparts') { 12131: my $navmap = Apache::lonnavmaps::navmap->new(); 12132: my $item; 12133: if (ref($navmap)) { 12134: my $res = $navmap->getBySymb($symbparm); 12135: my $parts = $res->parts(); 12136: if (ref($parts) eq 'ARRAY') { 12137: $item = join(',',@{$parts}); 12138: } 12139: undef($navmap); 12140: } 12141: return $item; 12142: } 12143: } 12144: } 12145: 12146: my ($section, $group, @groups, @recurseup, $recursed); 12147: my ($courselevelm,$courseleveli,$courselevel,$mapp); 12148: if (($courseid eq '') && ($cid)) { 12149: $courseid = $cid; 12150: } 12151: if (($symbparm && $courseid) && 12152: (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) { 12153: 12154: #print ' '.$space.' - '.$qualifier.' - '.$spacequalifierrest; 12155: 12156: # ----------------------------------------------------- Cascading lookup scheme 12157: my $symbp=$symbparm; 12158: $mapp=&deversion((&decode_symb($symbp))[0]); 12159: my $symbparm=$symbp.'.'.$spacequalifierrest; 12160: my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest; 12161: my $mapparm=$mapp.'___(all).'.$spacequalifierrest; 12162: if (($env{'user.name'} eq $uname) && 12163: ($env{'user.domain'} eq $udom)) { 12164: $section=$env{'request.course.sec'}; 12165: @groups = split(/:/,$env{'request.course.groups'}); 12166: @groups=&sort_course_groups($courseid,@groups); 12167: } else { 12168: if (! defined($usection)) { 12169: $section=&getsection($udom,$uname,$courseid); 12170: } else { 12171: $section = $usection; 12172: } 12173: @groups = &get_users_groups($udom,$uname,$courseid); 12174: } 12175: 12176: my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; 12177: my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; 12178: my $secleveli=$courseid.'.['.$section.'].'.$recurseparm; 12179: my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; 12180: 12181: $courselevel=$courseid.'.'.$spacequalifierrest; 12182: my $courselevelr=$courseid.'.'.$symbparm; 12183: $courseleveli=$courseid.'.'.$recurseparm; 12184: $courselevelm=$courseid.'.'.$mapparm; 12185: 12186: # ----------------------------------------------------------- first, check user 12187: 12188: my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed, 12189: \@recurseup,$courseid,'.',$spacequalifierrest, 12190: ([$courselevelr,'resource'], 12191: [$courselevelm,'map' ], 12192: [$courseleveli,'map' ], 12193: [$courselevel, 'course' ])); 12194: if (defined($userreply)) { return &get_reply($userreply); } 12195: 12196: # ------------------------------------------------ second, check some of course 12197: my $coursereply; 12198: if (@groups > 0) { 12199: $coursereply = &check_group_parms($courseid,\@groups,$symbparm, 12200: $recurseparm,$mapparm,$spacequalifierrest, 12201: $mapp,\$recursed,\@recurseup); 12202: if (defined($coursereply)) { return &get_reply($coursereply); } 12203: } 12204: 12205: $coursereply=&resdata($env{'course.'.$courseid.'.num'}, 12206: $env{'course.'.$courseid.'.domain'}, 12207: 'course',$mapp,\$recursed,\@recurseup, 12208: $courseid,'.['.$section.'].',$spacequalifierrest, 12209: ([$seclevelr, 'resource'], 12210: [$seclevelm, 'map' ], 12211: [$secleveli, 'map' ], 12212: [$seclevel, 'course' ], 12213: [$courselevelr,'resource'])); 12214: if (defined($coursereply)) { return &get_reply($coursereply); } 12215: 12216: # ------------------------------------------------------ third, check map parms 12217: my %parmhash=(); 12218: my $thisparm=''; 12219: if (tie(%parmhash,'GDBM_File', 12220: $env{'request.course.fn'}.'_parms.db', 12221: &GDBM_READER(),0640)) { 12222: $thisparm=$parmhash{$symbparm}; 12223: untie(%parmhash); 12224: } 12225: if ($thisparm) { return &get_reply([$thisparm,'resource']); } 12226: } 12227: # ------------------------------------------ fourth, look in resource metadata 12228: 12229: my $what = $spacequalifierrest; 12230: $what=~s/\./\_/; 12231: my $filename; 12232: if (!$symbparm) { $symbparm=&symbread(); } 12233: if ($symbparm) { 12234: $filename=(&decode_symb($symbparm))[2]; 12235: } else { 12236: $filename=$env{'request.filename'}; 12237: } 12238: my $toolsymb; 12239: if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) { 12240: $toolsymb = $symbparm; 12241: } 12242: my $metadata=&metadata($filename,$what,$toolsymb); 12243: if (defined($metadata)) { return &get_reply([$metadata,'resource']); } 12244: $metadata=&metadata($filename,'parameter_'.$what,$toolsymb); 12245: if (defined($metadata)) { return &get_reply([$metadata,'resource']); } 12246: 12247: # ----------------------------------------------- fifth, look in rest of course 12248: if ($symbparm && defined($courseid) && 12249: $courseid eq $env{'request.course.id'}) { 12250: my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, 12251: $env{'course.'.$courseid.'.domain'}, 12252: 'course',$mapp,\$recursed,\@recurseup, 12253: $courseid,'.',$spacequalifierrest, 12254: ([$courselevelm,'map' ], 12255: [$courseleveli,'map' ], 12256: [$courselevel, 'course'])); 12257: if (defined($coursereply)) { return &get_reply($coursereply); } 12258: } 12259: # ------------------------------------------------------------------ Cascade up 12260: unless ($space eq '0') { 12261: my @parts=split(/_/,$space); 12262: my $id=pop(@parts); 12263: my $part=join('_',@parts); 12264: if ($part eq '') { $part='0'; } 12265: my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, 12266: $symbparm,$udom,$uname,$section,1); 12267: if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } 12268: } 12269: if ($recurse) { return undef; } 12270: my $pack_def=&packages_tab_default($filename,$varname,$toolsymb); 12271: if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } 12272: # ---------------------------------------------------- Any other user namespace 12273: } elsif ($realm eq 'environment') { 12274: # ----------------------------------------------------------------- environment 12275: if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) { 12276: return $env{'environment.'.$spacequalifierrest}; 12277: } else { 12278: if ($uname eq 'anonymous' && $udom eq '') { 12279: return ''; 12280: } 12281: my %returnhash=&userenvironment($udom,$uname, 12282: $spacequalifierrest); 12283: return $returnhash{$spacequalifierrest}; 12284: } 12285: } elsif ($realm eq 'system') { 12286: # ----------------------------------------------------------------- system.time 12287: if ($space eq 'time') { 12288: return time; 12289: } 12290: } elsif ($realm eq 'server') { 12291: # ----------------------------------------------------------------- system.time 12292: if ($space eq 'name') { 12293: return $ENV{'SERVER_NAME'}; 12294: } 12295: } elsif ($realm eq 'client') { 12296: if ($space eq 'remote_addr') { 12297: return $ENV{'REMOTE_ADDR'}; 12298: } 12299: } 12300: return ''; 12301: } 12302: 12303: sub get_reply { 12304: my ($reply_value) = @_; 12305: if (ref($reply_value) eq 'ARRAY') { 12306: if (wantarray) { 12307: return @$reply_value; 12308: } 12309: return $reply_value->[0]; 12310: } else { 12311: return $reply_value; 12312: } 12313: } 12314: 12315: sub check_group_parms { 12316: my ($courseid,$groups,$symbparm,$recurseparm,$mapparm,$what,$mapp, 12317: $recursed,$recurseupref) = @_; 12318: my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$recurseparm,'map'], 12319: [$what,'course']); 12320: my $coursereply; 12321: foreach my $group (@{$groups}) { 12322: my @groupitems = (); 12323: foreach my $level (@levels) { 12324: my $item = $courseid.'.['.$group.'].'.$level->[0]; 12325: push(@groupitems,[$item,$level->[1]]); 12326: } 12327: my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, 12328: $env{'course.'.$courseid.'.domain'}, 12329: 'course',$mapp,$recursed,$recurseupref, 12330: $courseid,'.['.$group.'].',$what, 12331: @groupitems); 12332: last if (defined($coursereply)); 12333: } 12334: return $coursereply; 12335: } 12336: 12337: sub get_map_hierarchy { 12338: my ($mapname,$courseid) = @_; 12339: my @recurseup = (); 12340: if ($mapname) { 12341: if (($cachedmapkey eq $courseid) && 12342: (abs($cachedmaptime-time)<5)) { 12343: if (ref($cachedmaps{$mapname}) eq 'ARRAY') { 12344: return @{$cachedmaps{$mapname}}; 12345: } 12346: } 12347: my $navmap = Apache::lonnavmaps::navmap->new(); 12348: if (ref($navmap)) { 12349: @recurseup = $navmap->recurseup_maps($mapname); 12350: undef($navmap); 12351: $cachedmaps{$mapname} = \@recurseup; 12352: $cachedmaptime=time; 12353: $cachedmapkey=$courseid; 12354: } 12355: } 12356: return @recurseup; 12357: } 12358: 12359: } 12360: 12361: sub sort_course_groups { # Sort groups based on defined rankings. Default is sort(). 12362: my ($courseid,@groups) = @_; 12363: @groups = sort(@groups); 12364: return @groups; 12365: } 12366: 12367: sub packages_tab_default { 12368: my ($uri,$varname,$toolsymb)=@_; 12369: my (undef,$part,$name)=split(/\./,$varname); 12370: 12371: my (@extension,@specifics,$do_default); 12372: foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) { 12373: my ($pack_type,$pack_part)=split(/_/,$package,2); 12374: if ($pack_type eq 'default') { 12375: $do_default=1; 12376: } elsif ($pack_type eq 'extension') { 12377: push(@extension,[$package,$pack_type,$pack_part]); 12378: } elsif ($pack_part eq $part || $pack_type eq 'part') { 12379: # only look at packages defaults for packages that this id is 12380: push(@specifics,[$package,$pack_type,$pack_part]); 12381: } 12382: } 12383: # first look for a package that matches the requested part id 12384: foreach my $package (@specifics) { 12385: my (undef,$pack_type,$pack_part)=@{$package}; 12386: next if ($pack_part ne $part); 12387: if (defined($packagetab{"$pack_type&$name&default"})) { 12388: return $packagetab{"$pack_type&$name&default"}; 12389: } 12390: } 12391: # look for any possible matching non extension_ package 12392: foreach my $package (@specifics) { 12393: my (undef,$pack_type,$pack_part)=@{$package}; 12394: if (defined($packagetab{"$pack_type&$name&default"})) { 12395: return $packagetab{"$pack_type&$name&default"}; 12396: } 12397: if ($pack_type eq 'part') { $pack_part='0'; } 12398: if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { 12399: return $packagetab{$pack_type."_".$pack_part."&$name&default"}; 12400: } 12401: } 12402: # look for any posible extension_ match 12403: foreach my $package (@extension) { 12404: my ($package,$pack_type)=@{$package}; 12405: if (defined($packagetab{"$pack_type&$name&default"})) { 12406: return $packagetab{"$pack_type&$name&default"}; 12407: } 12408: if (defined($packagetab{$package."&$name&default"})) { 12409: return $packagetab{$package."&$name&default"}; 12410: } 12411: } 12412: # look for a global default setting 12413: if ($do_default && defined($packagetab{"default&$name&default"})) { 12414: return $packagetab{"default&$name&default"}; 12415: } 12416: return undef; 12417: } 12418: 12419: sub add_prefix_and_part { 12420: my ($prefix,$part)=@_; 12421: my $keyroot; 12422: if (defined($prefix) && $prefix !~ /^__/) { 12423: # prefix that has a part already 12424: $keyroot=$prefix; 12425: } elsif (defined($prefix)) { 12426: # prefix that is missing a part 12427: if (defined($part)) { $keyroot='_'.$part.substr($prefix,1); } 12428: } else { 12429: # no prefix at all 12430: if (defined($part)) { $keyroot='_'.$part; } 12431: } 12432: return $keyroot; 12433: } 12434: 12435: # ---------------------------------------------------------------- Get metadata 12436: 12437: my %metaentry; 12438: my %importedpartids; 12439: my %importedrespids; 12440: sub metadata { 12441: my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_; 12442: $uri=&declutter($uri); 12443: # if it is a non metadata possible uri return quickly 12444: if (($uri eq '') || 12445: (($uri =~ m|^/*adm/|) && 12446: ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || 12447: ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { 12448: return undef; 12449: } 12450: if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv}) 12451: && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) { 12452: return undef; 12453: } 12454: my $filename=$uri; 12455: $uri=~s/\.meta$//; 12456: # 12457: # Is the metadata already cached? 12458: # Look at timestamp of caching 12459: # Everything is cached by the main uri, libraries are never directly cached 12460: # 12461: if (!defined($liburi)) { 12462: my ($result,$cached)=&is_cached_new('meta',$uri); 12463: if (defined($cached)) { return $result->{':'.$what}; } 12464: } 12465: 12466: # 12467: # If the uri is for an external tool the file from 12468: # which metadata should be retrieved depends on whether 12469: # the tool had been configured to be gradable (set in the Course 12470: # Editor or Resource Editor). 12471: # 12472: # If a valid symb has been included as the third arg in the call 12473: # to &metadata() that can be used to retrieve the value of 12474: # parameter_0_gradable set for the resource, and included in the 12475: # uploaded map containing the tool. The value is retrieved via 12476: # &EXT(), if a valid symb is available. Otherwise the value of 12477: # gradable in the exttool_$marker.db file for the tool instance 12478: # is retrieved via &get(). 12479: # 12480: # When lonuserstate::traceroute() calls lonnet::EXT() for 12481: # hiddenresource and encrypturl (during course initialization) 12482: # the map-level parameter for resource.0.gradable included in the 12483: # uploaded map containing the tool will not yet have been stored 12484: # in the user_course_parms.db file for the user's session, so in 12485: # this case fall back to retrieving gradable status from the 12486: # exttool_$marker.db file. 12487: # 12488: # In order to avoid an infinite loop, &metadata() will return 12489: # before a call to &EXT(), if the uri is for an external tool 12490: # and the $what for which metadata is being requested is 12491: # parameter_0_gradable or 0_gradable. 12492: # 12493: 12494: if ($uri =~ /ext\.tool$/) { 12495: if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) { 12496: return; 12497: } else { 12498: my ($checked,$use_passback); 12499: if ($toolsymb ne '') { 12500: (undef,undef,my $tooluri) = &decode_symb($toolsymb); 12501: if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) { 12502: $checked = 1; 12503: if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) { 12504: $use_passback = 1; 12505: } 12506: } 12507: } 12508: unless ($checked) { 12509: my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri); 12510: $marker=~s/\D//g; 12511: if ($marker) { 12512: my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum); 12513: $use_passback = $toolsettings{'gradable'}; 12514: } 12515: } 12516: if ($use_passback) { 12517: $filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool'; 12518: } else { 12519: $filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool'; 12520: } 12521: } 12522: } 12523: 12524: { 12525: # Imported parts would go here 12526: my @origfiletagids=(); 12527: my $importedparts=0; 12528: 12529: # Imported responseids would go here 12530: my $importedresponses=0; 12531: # 12532: # Is this a recursive call for a library? 12533: # 12534: # if (! exists($metacache{$uri})) { 12535: # $metacache{$uri}={}; 12536: # } 12537: my $cachetime = 60*60; 12538: if ($liburi) { 12539: $liburi=&declutter($liburi); 12540: $filename=$liburi; 12541: } else { 12542: &devalidate_cache_new('meta',$uri); 12543: undef(%metaentry); 12544: } 12545: my %metathesekeys=(); 12546: unless ($filename=~/\.meta$/) { $filename.='.meta'; } 12547: my $metastring; 12548: if ($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) { 12549: my $which = &hreflocation('','/'.($liburi || $uri)); 12550: $metastring = 12551: &Apache::lonnet::ssi_body($which, 12552: ('grade_target' => 'meta')); 12553: $cachetime = 1; # only want this cached in the child not long term 12554: } elsif (($uri !~ m -^(editupload)/-) && 12555: ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) { 12556: my $file=&filelocation('',&clutter($filename)); 12557: #push(@{$metaentry{$uri.'.file'}},$file); 12558: $metastring=&getfile($file); 12559: } 12560: my $parser=HTML::LCParser->new(\$metastring); 12561: my $token; 12562: undef %metathesekeys; 12563: while ($token=$parser->get_token) { 12564: if ($token->[0] eq 'S') { 12565: if (defined($token->[2]->{'package'})) { 12566: # 12567: # This is a package - get package info 12568: # 12569: my $package=$token->[2]->{'package'}; 12570: my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'}); 12571: if (defined($token->[2]->{'id'})) { 12572: $keyroot.='_'.$token->[2]->{'id'}; 12573: } 12574: if ($metaentry{':packages'}) { 12575: $metaentry{':packages'}.=','.$package.$keyroot; 12576: } else { 12577: $metaentry{':packages'}=$package.$keyroot; 12578: } 12579: foreach my $pack_entry (keys(%packagetab)) { 12580: my $part=$keyroot; 12581: $part=~s/^\_//; 12582: if ($pack_entry=~/^\Q$package\E\&/ || 12583: $pack_entry=~/^\Q$package\E_0\&/) { 12584: my ($pack,$name,$subp)=split(/\&/,$pack_entry); 12585: # ignore package.tab specified default values 12586: # here &package_tab_default() will fetch those 12587: if ($subp eq 'default') { next; } 12588: my $value=$packagetab{$pack_entry}; 12589: my $unikey; 12590: if ($pack =~ /_0$/) { 12591: $unikey='parameter_0_'.$name; 12592: $part=0; 12593: } else { 12594: $unikey='parameter'.$keyroot.'_'.$name; 12595: } 12596: if ($subp eq 'display') { 12597: $value.=' [Part: '.$part.']'; 12598: } 12599: $metaentry{':'.$unikey.'.part'}=$part; 12600: $metathesekeys{$unikey}=1; 12601: unless (defined($metaentry{':'.$unikey.'.'.$subp})) { 12602: $metaentry{':'.$unikey.'.'.$subp}=$value; 12603: } 12604: if (defined($metaentry{':'.$unikey.'.default'})) { 12605: $metaentry{':'.$unikey}= 12606: $metaentry{':'.$unikey.'.default'}; 12607: } 12608: } 12609: } 12610: } else { 12611: # 12612: # This is not a package - some other kind of start tag 12613: # 12614: my $entry=$token->[1]; 12615: my $unikey=''; 12616: 12617: if ($entry eq 'import') { 12618: # 12619: # Importing a library here 12620: # 12621: my $location=$parser->get_text('/import'); 12622: my $dir=$filename; 12623: $dir=~s|[^/]*$||; 12624: $location=&filelocation($dir,$location); 12625: 12626: my $importid=$token->[2]->{'id'}; 12627: my $importmode=$token->[2]->{'importmode'}; 12628: # 12629: # Check metadata for imported file to 12630: # see if it contained response items 12631: # 12632: my ($origfile,@libfilekeys); 12633: my %currmetaentry = %metaentry; 12634: @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef, 12635: $depthcount+1)); 12636: if (grep(/^responseorder$/,@libfilekeys)) { 12637: my $libresponseorder = &metadata($location,'responseorder',undef,undef, 12638: undef,$depthcount+1); 12639: if ($libresponseorder ne '') { 12640: if ($#origfiletagids<0) { 12641: undef(%importedrespids); 12642: undef(%importedpartids); 12643: } 12644: my @respids = split(/\s*,\s*/,$libresponseorder); 12645: if (@respids) { 12646: $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids); 12647: } 12648: if ($importedrespids{$importid} ne '') { 12649: $importedresponses = 1; 12650: # We need to get the original file and the imported file to get the response order correct 12651: # Load and inspect original file 12652: if ($#origfiletagids<0) { 12653: my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); 12654: $origfile=&getfile($origfilelocation); 12655: @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); 12656: } 12657: } 12658: } 12659: } 12660: # Do not overwrite contents of %metaentry hash for resource itself with 12661: # hash populated for imported library file 12662: %metaentry = %currmetaentry; 12663: undef(%currmetaentry); 12664: if ($importmode eq 'part') { 12665: # Import as part(s) 12666: $importedparts=1; 12667: # We need to get the original file and the imported file to get the part order correct 12668: # Good news: we do not need to worry about nested libraries, since parts cannot be nested 12669: # Load and inspect original file if we didn't do that already 12670: if ($#origfiletagids<0) { 12671: undef(%importedrespids); 12672: undef(%importedpartids); 12673: if ($origfile eq '') { 12674: my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); 12675: $origfile=&getfile($origfilelocation); 12676: @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); 12677: } 12678: } 12679: my @impfilepartids; 12680: # If <partorder> tag is included in metadata for the imported file 12681: # get the parts in the imported file from that. 12682: if (grep(/^partorder$/,@libfilekeys)) { 12683: %currmetaentry = %metaentry; 12684: my $libpartorder = &metadata($location,'partorder',undef,undef,undef, 12685: $depthcount+1); 12686: %metaentry = %currmetaentry; 12687: undef(%currmetaentry); 12688: if ($libpartorder ne '') { 12689: @impfilepartids=split(/\s*,\s*/,$libpartorder); 12690: } 12691: } else { 12692: # If no <partorder> tag available, load and inspect imported file 12693: my $impfile=&getfile($location); 12694: @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); 12695: } 12696: if ($#impfilepartids>=0) { 12697: # This problem had parts 12698: $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); 12699: } else { 12700: # Importing by turning a single problem into a problem part 12701: # It gets the import-tags ID as part-ID 12702: $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'}); 12703: $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'}; 12704: } 12705: } else { 12706: # Import as problem or as normal import 12707: $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); 12708: unless ($importmode eq 'problem') { 12709: # Normal import 12710: if (defined($token->[2]->{'id'})) { 12711: $unikey.='_'.$token->[2]->{'id'}; 12712: } 12713: } 12714: # Check metadata for imported file to 12715: # see if it contained parts 12716: if (grep(/^partorder$/,@libfilekeys)) { 12717: %currmetaentry = %metaentry; 12718: my $libpartorder = &metadata($location,'partorder',undef,undef,undef, 12719: $depthcount+1); 12720: %metaentry = %currmetaentry; 12721: undef(%currmetaentry); 12722: if ($libpartorder ne '') { 12723: $importedparts = 1; 12724: $importedpartids{$token->[2]->{'id'}}=$libpartorder; 12725: } 12726: } 12727: } 12728: if ($depthcount<20) { 12729: my $metadata = 12730: &metadata($uri,'keys',$toolsymb,$location,$unikey, 12731: $depthcount+1); 12732: foreach my $meta (split(',',$metadata)) { 12733: $metaentry{':'.$meta}=$metaentry{':'.$meta}; 12734: $metathesekeys{$meta}=1; 12735: } 12736: } 12737: } else { 12738: # 12739: # Not importing, some other kind of non-package, non-library start tag 12740: # 12741: $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'}); 12742: if (defined($token->[2]->{'id'})) { 12743: $unikey.='_'.$token->[2]->{'id'}; 12744: } 12745: if (defined($token->[2]->{'name'})) { 12746: $unikey.='_'.$token->[2]->{'name'}; 12747: } 12748: $metathesekeys{$unikey}=1; 12749: foreach my $param (@{$token->[3]}) { 12750: $metaentry{':'.$unikey.'.'.$param} = 12751: $token->[2]->{$param}; 12752: } 12753: my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); 12754: my $default=$metaentry{':'.$unikey.'.default'}; 12755: if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { 12756: # only ws inside the tag, and not in default, so use default 12757: # as value 12758: $metaentry{':'.$unikey}=$default; 12759: } elsif ( $internaltext =~ /\S/ ) { 12760: # something interesting inside the tag 12761: $metaentry{':'.$unikey}=$internaltext; 12762: } else { 12763: # no interesting values, don't set a default 12764: } 12765: # end of not-a-package not-a-library import 12766: } 12767: # end of not-a-package start tag 12768: } 12769: # the next is the end of "start tag" 12770: } 12771: } 12772: my ($extension) = ($uri =~ /\.(\w+)$/); 12773: $extension = lc($extension); 12774: if ($extension eq 'htm') { $extension='html'; } 12775: 12776: foreach my $key (keys(%packagetab)) { 12777: #no specific packages #how's our extension 12778: if ($key!~/^extension_\Q$extension\E&/) { next; } 12779: &metadata_create_package_def($uri,$key,'extension_'.$extension, 12780: \%metathesekeys); 12781: } 12782: 12783: if (!exists($metaentry{':packages'}) 12784: || $packagetab{"import_defaults&extension_$extension"}) { 12785: foreach my $key (keys(%packagetab)) { 12786: #no specific packages well let's get default then 12787: if ($key!~/^default&/) { next; } 12788: &metadata_create_package_def($uri,$key,'default', 12789: \%metathesekeys); 12790: } 12791: } 12792: # are there custom rights to evaluate 12793: if ($metaentry{':copyright'} eq 'custom') { 12794: 12795: # 12796: # Importing a rights file here 12797: # 12798: unless ($depthcount) { 12799: my $location=$metaentry{':customdistributionfile'}; 12800: my $dir=$filename; 12801: $dir=~s|[^/]*$||; 12802: $location=&filelocation($dir,$location); 12803: my $rights_metadata = 12804: &metadata($uri,'keys',$toolsymb,$location,'_rights', 12805: $depthcount+1); 12806: foreach my $rights (split(',',$rights_metadata)) { 12807: #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; 12808: $metathesekeys{$rights}=1; 12809: } 12810: } 12811: } 12812: # uniqifiy package listing 12813: my %seen; 12814: my @uniq_packages = 12815: grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); 12816: $metaentry{':packages'} = join(',',@uniq_packages); 12817: 12818: if (($importedresponses) || ($importedparts)) { 12819: if ($importedparts) { 12820: # We had imported parts and need to rebuild partorder 12821: $metaentry{':partorder'}=''; 12822: $metathesekeys{'partorder'}=1; 12823: } 12824: if ($importedresponses) { 12825: # We had imported responses and need to rebuil responseorder 12826: $metaentry{':responseorder'}=''; 12827: $metathesekeys{'responseorder'}=1; 12828: } 12829: for (my $index=0;$index<$#origfiletagids;$index+=2) { 12830: my $origid = $origfiletagids[$index+1]; 12831: if ($origfiletagids[$index] eq 'part') { 12832: # Original part, part of the problem 12833: if ($importedparts) { 12834: $metaentry{':partorder'}.=','.$origid; 12835: } 12836: } elsif ($origfiletagids[$index] eq 'import') { 12837: if ($importedparts) { 12838: # We have imported parts at this position 12839: if ($importedpartids{$origid} ne '') { 12840: $metaentry{':partorder'}.=','.$importedpartids{$origid}; 12841: } 12842: } 12843: if ($importedresponses) { 12844: # We have imported responses at this position 12845: if ($importedrespids{$origid} ne '') { 12846: $metaentry{':responseorder'}.=','.$importedrespids{$origid}; 12847: } 12848: } 12849: } else { 12850: # Original response item, part of the problem 12851: if ($importedresponses) { 12852: $metaentry{':responseorder'}.=','.$origid; 12853: } 12854: } 12855: } 12856: if ($importedparts) { 12857: $metaentry{':partorder'}=~s/^\,//; 12858: } 12859: if ($importedresponses) { 12860: $metaentry{':responseorder'}=~s/^\,//; 12861: } 12862: } 12863: $metaentry{':keys'} = join(',',keys(%metathesekeys)); 12864: &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); 12865: $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys)); 12866: unless ($liburi) { 12867: &do_cache_new('meta',$uri,\%metaentry,$cachetime); 12868: } 12869: # this is the end of "was not already recently cached 12870: } 12871: return $metaentry{':'.$what}; 12872: } 12873: 12874: sub metadata_create_package_def { 12875: my ($uri,$key,$package,$metathesekeys)=@_; 12876: my ($pack,$name,$subp)=split(/\&/,$key); 12877: if ($subp eq 'default') { next; } 12878: 12879: if (defined($metaentry{':packages'})) { 12880: $metaentry{':packages'}.=','.$package; 12881: } else { 12882: $metaentry{':packages'}=$package; 12883: } 12884: my $value=$packagetab{$key}; 12885: my $unikey; 12886: $unikey='parameter_0_'.$name; 12887: $metaentry{':'.$unikey.'.part'}=0; 12888: $$metathesekeys{$unikey}=1; 12889: unless (defined($metaentry{':'.$unikey.'.'.$subp})) { 12890: $metaentry{':'.$unikey.'.'.$subp}=$value; 12891: } 12892: if (defined($metaentry{':'.$unikey.'.default'})) { 12893: $metaentry{':'.$unikey}= 12894: $metaentry{':'.$unikey.'.default'}; 12895: } 12896: } 12897: 12898: sub metadata_generate_part0 { 12899: my ($metadata,$metacache,$uri) = @_; 12900: my %allnames; 12901: foreach my $metakey (keys(%$metadata)) { 12902: if ($metakey=~/^parameter\_(.*)/) { 12903: my $part=$$metacache{':'.$metakey.'.part'}; 12904: my $name=$$metacache{':'.$metakey.'.name'}; 12905: if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { 12906: $allnames{$name}=$part; 12907: } 12908: } 12909: } 12910: foreach my $name (keys(%allnames)) { 12911: $$metadata{"parameter_0_$name"}=1; 12912: my $key=":parameter_0_$name"; 12913: $$metacache{"$key.part"}='0'; 12914: $$metacache{"$key.name"}=$name; 12915: $$metacache{"$key.type"}=$$metacache{':parameter_'. 12916: $allnames{$name}.'_'.$name. 12917: '.type'}; 12918: my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. 12919: '.display'}; 12920: my $expr='[Part: '.$allnames{$name}.']'; 12921: $olddis=~s/\Q$expr\E/\[Part: 0\]/; 12922: $$metacache{"$key.display"}=$olddis; 12923: } 12924: } 12925: 12926: # ------------------------------------------------------ Devalidate title cache 12927: 12928: sub devalidate_title_cache { 12929: my ($url)=@_; 12930: if (!$env{'request.course.id'}) { return; } 12931: my $symb=&symbread($url); 12932: if (!$symb) { return; } 12933: my $key=$env{'request.course.id'}."\0".$symb; 12934: &devalidate_cache_new('title',$key); 12935: } 12936: 12937: # ------------------------------------------------- Get the title of a course 12938: 12939: sub current_course_title { 12940: return $env{ 'course.' . $env{'request.course.id'} . '.description' }; 12941: } 12942: # ------------------------------------------------- Get the title of a resource 12943: 12944: sub gettitle { 12945: my $urlsymb=shift; 12946: my $symb=&symbread($urlsymb); 12947: if ($symb) { 12948: my $key=$env{'request.course.id'}."\0".$symb; 12949: my ($result,$cached)=&is_cached_new('title',$key); 12950: if (defined($cached)) { 12951: return $result; 12952: } 12953: my ($map,$resid,$url)=&decode_symb($symb); 12954: my $title=''; 12955: if (!$map && $resid == 0 && $url =~/default\.sequence$/) { 12956: $title = $env{'course.'.$env{'request.course.id'}.'.description'}; 12957: } else { 12958: if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db', 12959: &GDBM_READER(),0640)) { 12960: my $mapid=$bighash{'map_pc_'.&clutter($map)}; 12961: $title=$bighash{'title_'.$mapid.'.'.$resid}; 12962: untie(%bighash); 12963: } 12964: } 12965: $title=~s/\&colon\;/\:/gs; 12966: if ($title) { 12967: # Remember both $symb and $title for dynamic metadata 12968: $accesshash{$symb.'___crstitle'}=$title; 12969: $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time; 12970: # Cache this title and then return it 12971: return &do_cache_new('title',$key,$title,600); 12972: } 12973: $urlsymb=$url; 12974: } 12975: my $title=&metadata($urlsymb,'title'); 12976: if (!$title) { $title=(split('/',$urlsymb))[-1]; } 12977: return $title; 12978: } 12979: 12980: sub get_slot { 12981: my ($which,$cnum,$cdom)=@_; 12982: if (!$cnum || !$cdom) { 12983: (undef,my $courseid)=&whichuser(); 12984: $cdom=$env{'course.'.$courseid.'.domain'}; 12985: $cnum=$env{'course.'.$courseid.'.num'}; 12986: } 12987: my $key=join("\0",'slots',$cdom,$cnum,$which); 12988: my %slotinfo; 12989: if (exists($remembered{$key})) { 12990: $slotinfo{$which} = $remembered{$key}; 12991: } else { 12992: %slotinfo=&get('slots',[$which],$cdom,$cnum); 12993: &Apache::lonhomework::showhash(%slotinfo); 12994: my ($tmp)=keys(%slotinfo); 12995: if ($tmp=~/^error:/) { return (); } 12996: $remembered{$key} = $slotinfo{$which}; 12997: } 12998: if (ref($slotinfo{$which}) eq 'HASH') { 12999: return %{$slotinfo{$which}}; 13000: } 13001: return $slotinfo{$which}; 13002: } 13003: 13004: sub get_reservable_slots { 13005: my ($cnum,$cdom,$uname,$udom) = @_; 13006: my $now = time; 13007: my $reservable_info; 13008: my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom); 13009: if (exists($remembered{$key})) { 13010: $reservable_info = $remembered{$key}; 13011: } else { 13012: my %resv; 13013: ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) = 13014: &Apache::loncommon::get_future_slots($cnum,$cdom,$now); 13015: $reservable_info = \%resv; 13016: $remembered{$key} = $reservable_info; 13017: } 13018: return $reservable_info; 13019: } 13020: 13021: sub get_course_slots { 13022: my ($cnum,$cdom) = @_; 13023: my $hashid=$cnum.':'.$cdom; 13024: my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid); 13025: if (defined($cached)) { 13026: if (ref($result) eq 'HASH') { 13027: return %{$result}; 13028: } 13029: } else { 13030: my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum); 13031: my ($tmp) = keys(%slots); 13032: if ($tmp !~ /^(con_lost|error|no_such_host)/i) { 13033: &do_cache_new('allslots',$hashid,\%slots,600); 13034: return %slots; 13035: } 13036: } 13037: return; 13038: } 13039: 13040: sub devalidate_slots_cache { 13041: my ($cnum,$cdom)=@_; 13042: my $hashid=$cnum.':'.$cdom; 13043: &devalidate_cache_new('allslots',$hashid); 13044: } 13045: 13046: sub get_coursechange { 13047: my ($cdom,$cnum) = @_; 13048: if ($cdom eq '' || $cnum eq '') { 13049: return unless ($env{'request.course.id'}); 13050: $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; 13051: $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; 13052: } 13053: my $hashid=$cdom.'_'.$cnum; 13054: my ($change,$cached)=&is_cached_new('crschange',$hashid); 13055: if ((defined($cached)) && ($change ne '')) { 13056: return $change; 13057: } else { 13058: my %crshash; 13059: %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum); 13060: if ($crshash{'internal.contentchange'} eq '') { 13061: $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'}; 13062: if ($change eq '') { 13063: %crshash = &get('environment',['internal.created'],$cdom,$cnum); 13064: $change = $crshash{'internal.created'}; 13065: } 13066: } else { 13067: $change = $crshash{'internal.contentchange'}; 13068: } 13069: my $cachetime = 600; 13070: &do_cache_new('crschange',$hashid,$change,$cachetime); 13071: } 13072: return $change; 13073: } 13074: 13075: sub devalidate_coursechange_cache { 13076: my ($cnum,$cdom)=@_; 13077: my $hashid=$cnum.':'.$cdom; 13078: &devalidate_cache_new('crschange',$hashid); 13079: } 13080: 13081: # ------------------------------------------------- Update symbolic store links 13082: 13083: sub symblist { 13084: my ($mapname,%newhash)=@_; 13085: $mapname=&deversion(&declutter($mapname)); 13086: my %hash; 13087: if (($env{'request.course.fn'}) && (%newhash)) { 13088: if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', 13089: &GDBM_WRCREAT(),0640)) { 13090: foreach my $url (keys(%newhash)) { 13091: next if ($url eq 'last_known' 13092: && $env{'form.no_update_last_known'}); 13093: $hash{declutter($url)}=&encode_symb($mapname, 13094: $newhash{$url}->[1], 13095: $newhash{$url}->[0]); 13096: } 13097: if (untie(%hash)) { 13098: return 'ok'; 13099: } 13100: } 13101: } 13102: return 'error'; 13103: } 13104: 13105: # --------------------------------------------------------------- Verify a symb 13106: 13107: sub symbverify { 13108: my ($symb,$thisurl,$encstate)=@_; 13109: my $thisfn=$thisurl; 13110: $thisfn=&declutter($thisfn); 13111: # direct jump to resource in page or to a sequence - will construct own symbs 13112: if ($thisfn=~/\.(page|sequence)$/) { return 1; } 13113: # check URL part 13114: my ($map,$resid,$url)=&decode_symb($symb); 13115: 13116: unless ($url eq $thisfn) { return 0; } 13117: 13118: $symb=&symbclean($symb); 13119: $thisurl=&deversion($thisurl); 13120: $thisfn=&deversion($thisfn); 13121: 13122: my %bighash; 13123: my $okay=0; 13124: 13125: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', 13126: &GDBM_READER(),0640)) { 13127: if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { 13128: $thisurl =~ s/\?.+$//; 13129: if ($map =~ m{^uploaded/.+\.page$}) { 13130: $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://}; 13131: $thisurl =~ s{^\Qhttp://https://\E}{https://}; 13132: } 13133: } 13134: my $ids; 13135: if ($map =~ m{^uploaded/.+\.page$}) { 13136: $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)}; 13137: } else { 13138: $ids=$bighash{'ids_'.&clutter($thisurl)}; 13139: } 13140: unless ($ids) { 13141: my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; 13142: $ids=$bighash{$idkey}; 13143: } 13144: if ($ids) { 13145: # ------------------------------------------------------------------- Has ID(s) 13146: if ($thisfn =~ m{^/adm/wrapper/ext/}) { 13147: $symb =~ s/\?.+$//; 13148: } 13149: foreach my $id (split(/\,/,$ids)) { 13150: my ($mapid,$resid)=split(/\./,$id); 13151: if ( 13152: &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) 13153: eq $symb) { 13154: if (ref($encstate)) { 13155: $$encstate = $bighash{'encrypted_'.$id}; 13156: } 13157: if (($env{'request.role.adv'}) || 13158: ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || 13159: ($thisurl eq '/adm/navmaps')) { 13160: $okay=1; 13161: last; 13162: } 13163: } 13164: } 13165: } 13166: untie(%bighash); 13167: } 13168: return $okay; 13169: } 13170: 13171: # --------------------------------------------------------------- Clean-up symb 13172: 13173: sub symbclean { 13174: my $symb=shift; 13175: if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } 13176: # remove version from map 13177: $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/; 13178: 13179: # remove version from URL 13180: $symb=~s/\.(\d+)\.(\w+)$/\.$2/; 13181: 13182: # remove wrapper 13183: 13184: $symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/; 13185: $symb=~s/(\_\_\_\d+\_\_\_)adm\/coursedocs\/showdoc\/(res\/)*/$1/; 13186: return $symb; 13187: } 13188: 13189: # ---------------------------------------------- Split symb to find map and url 13190: 13191: sub encode_symb { 13192: my ($map,$resid,$url)=@_; 13193: return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url)); 13194: } 13195: 13196: sub decode_symb { 13197: my $symb=shift; 13198: if ($symb=~m|^/enc/|) { $symb=&Apache::lonenc::unencrypted($symb); } 13199: my ($map,$resid,$url)=split(/___/,$symb); 13200: return (&fixversion($map),$resid,&fixversion($url)); 13201: } 13202: 13203: sub fixversion { 13204: my $fn=shift; 13205: if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; } 13206: my %bighash; 13207: my $uri=&clutter($fn); 13208: my $key=$env{'request.course.id'}.'_'.$uri; 13209: # is this cached? 13210: my ($result,$cached)=&is_cached_new('courseresversion',$key); 13211: if (defined($cached)) { return $result; } 13212: # unfortunately not cached, or expired 13213: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', 13214: &GDBM_READER(),0640)) { 13215: if ($bighash{'version_'.$uri}) { 13216: my $version=$bighash{'version_'.$uri}; 13217: unless (($version eq 'mostrecent') || 13218: ($version==&getversion($uri))) { 13219: $uri=~s/\.(\w+)$/\.$version\.$1/; 13220: } 13221: } 13222: untie %bighash; 13223: } 13224: return &do_cache_new('courseresversion',$key,&declutter($uri),600); 13225: } 13226: 13227: sub deversion { 13228: my $url=shift; 13229: $url=~s/\.\d+\.(\w+)$/\.$1/; 13230: return $url; 13231: } 13232: 13233: # ------------------------------------------------------ Return symb list entry 13234: 13235: sub symbread { 13236: my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; 13237: my $cache_str='request.symbread.cached.'.$thisfn; 13238: if (defined($env{$cache_str})) { 13239: if ($ignorecachednull) { 13240: return $env{$cache_str} unless ($env{$cache_str} eq ''); 13241: } else { 13242: return $env{$cache_str}; 13243: } 13244: } 13245: # no filename provided? try from environment 13246: unless ($thisfn) { 13247: if ($env{'request.symb'}) { 13248: return $env{$cache_str}=&symbclean($env{'request.symb'}); 13249: } 13250: $thisfn=$env{'request.filename'}; 13251: } 13252: if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } 13253: # is that filename actually a symb? Verify, clean, and return 13254: if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { 13255: if (&symbverify($thisfn,$1)) { 13256: return $env{$cache_str}=&symbclean($thisfn); 13257: } 13258: } 13259: $thisfn=declutter($thisfn); 13260: my %hash; 13261: my %bighash; 13262: my $syval=''; 13263: if (($env{'request.course.fn'}) && ($thisfn)) { 13264: my $targetfn = $thisfn; 13265: if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { 13266: $targetfn = 'adm/wrapper/'.$thisfn; 13267: } 13268: if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { 13269: $targetfn=$1; 13270: } 13271: if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', 13272: &GDBM_READER(),0640)) { 13273: $syval=$hash{$targetfn}; 13274: untie(%hash); 13275: } 13276: # ---------------------------------------------------------- There was an entry 13277: if ($syval) { 13278: #unless ($syval=~/\_\d+$/) { 13279: #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { 13280: #&appenv({'request.ambiguous' => $thisfn}); 13281: #return $env{$cache_str}=''; 13282: #} 13283: #$syval.=$1; 13284: #} 13285: } else { 13286: # ------------------------------------------------------- Was not in symb table 13287: if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', 13288: &GDBM_READER(),0640)) { 13289: # ---------------------------------------------- Get ID(s) for current resource 13290: my $ids=$bighash{'ids_'.&clutter($thisfn)}; 13291: unless ($ids) { 13292: $ids=$bighash{'ids_/'.$thisfn}; 13293: } 13294: unless ($ids) { 13295: # alias? 13296: $ids=$bighash{'mapalias_'.$thisfn}; 13297: } 13298: if ($ids) { 13299: # ------------------------------------------------------------------- Has ID(s) 13300: my @possibilities=split(/\,/,$ids); 13301: if ($#possibilities==0) { 13302: # ----------------------------------------------- There is only one possibility 13303: my ($mapid,$resid)=split(/\./,$ids); 13304: $syval=&encode_symb($bighash{'map_id_'.$mapid}, 13305: $resid,$thisfn); 13306: if (ref($possibles) eq 'HASH') { 13307: $possibles->{$syval} = 1; 13308: } 13309: if ($checkforblock) { 13310: my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); 13311: if (@blockers) { 13312: $syval = ''; 13313: return; 13314: } 13315: } 13316: } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { 13317: # ------------------------------------------ There is more than one possibility 13318: my $realpossible=0; 13319: foreach my $id (@possibilities) { 13320: my $file=$bighash{'src_'.$id}; 13321: my $canaccess; 13322: if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { 13323: $canaccess = 1; 13324: } else { 13325: $canaccess = &allowed('bre',$file); 13326: } 13327: if ($canaccess) { 13328: my ($mapid,$resid)=split(/\./,$id); 13329: if ($bighash{'map_type_'.$mapid} ne 'page') { 13330: my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, 13331: $resid,$thisfn); 13332: if (ref($possibles) eq 'HASH') { 13333: $possibles->{$syval} = 1; 13334: } 13335: if ($checkforblock) { 13336: my @blockers = &has_comm_blocking('bre',$poss_syval,$file); 13337: unless (@blockers > 0) { 13338: $syval = $poss_syval; 13339: $realpossible++; 13340: } 13341: } else { 13342: $syval = $poss_syval; 13343: $realpossible++; 13344: } 13345: } 13346: } 13347: } 13348: if ($realpossible!=1) { $syval=''; } 13349: } else { 13350: $syval=''; 13351: } 13352: } 13353: untie(%bighash); 13354: } 13355: } 13356: if ($syval) { 13357: return $env{$cache_str}=$syval; 13358: } 13359: } 13360: &appenv({'request.ambiguous' => $thisfn}); 13361: return $env{$cache_str}=''; 13362: } 13363: 13364: # ---------------------------------------------------------- Return random seed 13365: 13366: sub numval { 13367: my $txt=shift; 13368: $txt=~tr/A-J/0-9/; 13369: $txt=~tr/a-j/0-9/; 13370: $txt=~tr/K-T/0-9/; 13371: $txt=~tr/k-t/0-9/; 13372: $txt=~tr/U-Z/0-5/; 13373: $txt=~tr/u-z/0-5/; 13374: $txt=~s/\D//g; 13375: if ($_64bit) { if ($txt > 2**32) { return -1; } } 13376: return int($txt); 13377: } 13378: 13379: sub numval2 { 13380: my $txt=shift; 13381: $txt=~tr/A-J/0-9/; 13382: $txt=~tr/a-j/0-9/; 13383: $txt=~tr/K-T/0-9/; 13384: $txt=~tr/k-t/0-9/; 13385: $txt=~tr/U-Z/0-5/; 13386: $txt=~tr/u-z/0-5/; 13387: $txt=~s/\D//g; 13388: my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); 13389: my $total; 13390: foreach my $val (@txts) { $total+=$val; } 13391: if ($_64bit) { if ($total > 2**32) { return -1; } } 13392: return int($total); 13393: } 13394: 13395: sub numval3 { 13396: use integer; 13397: my $txt=shift; 13398: $txt=~tr/A-J/0-9/; 13399: $txt=~tr/a-j/0-9/; 13400: $txt=~tr/K-T/0-9/; 13401: $txt=~tr/k-t/0-9/; 13402: $txt=~tr/U-Z/0-5/; 13403: $txt=~tr/u-z/0-5/; 13404: $txt=~s/\D//g; 13405: my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt); 13406: my $total; 13407: foreach my $val (@txts) { $total+=$val; } 13408: if ($_64bit) { $total=(($total<<32)>>32); } 13409: return $total; 13410: } 13411: 13412: sub digest { 13413: my ($data)=@_; 13414: my $digest=&Digest::MD5::md5($data); 13415: my ($a,$b,$c,$d)=unpack("iiii",$digest); 13416: my ($e,$f); 13417: { 13418: use integer; 13419: $e=($a+$b); 13420: $f=($c+$d); 13421: if ($_64bit) { 13422: $e=(($e<<32)>>32); 13423: $f=(($f<<32)>>32); 13424: } 13425: } 13426: if (wantarray) { 13427: return ($e,$f); 13428: } else { 13429: my $g; 13430: { 13431: use integer; 13432: $g=($e+$f); 13433: if ($_64bit) { 13434: $g=(($g<<32)>>32); 13435: } 13436: } 13437: return $g; 13438: } 13439: } 13440: 13441: sub latest_rnd_algorithm_id { 13442: return '64bit5'; 13443: } 13444: 13445: sub get_rand_alg { 13446: my ($courseid)=@_; 13447: if (!$courseid) { $courseid=(&whichuser())[1]; } 13448: if ($courseid) { 13449: return $env{"course.$courseid.rndseed"}; 13450: } 13451: return &latest_rnd_algorithm_id(); 13452: } 13453: 13454: sub validCODE { 13455: my ($CODE)=@_; 13456: if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; } 13457: return 0; 13458: } 13459: 13460: sub getCODE { 13461: if (&validCODE($env{'form.CODE'})) { return $env{'form.CODE'}; } 13462: if ( (defined($Apache::lonhomework::parsing_a_problem) || 13463: defined($Apache::lonhomework::parsing_a_task) ) && 13464: &validCODE($Apache::lonhomework::history{'resource.CODE'})) { 13465: return $Apache::lonhomework::history{'resource.CODE'}; 13466: } 13467: return undef; 13468: } 13469: # 13470: # Determines the random seed for a specific context: 13471: # 13472: # parameters: 13473: # symb - in course context the symb for the seed. 13474: # course_id - The course id of the form domain_coursenum. 13475: # domain - Domain for the user. 13476: # course - Course for the user. 13477: # cenv - environment of the course. 13478: # 13479: # NOTE: 13480: # All parameters are picked out of the environment if missing 13481: # or not defined. 13482: # If a symb cannot be determined the current time is used instead. 13483: # 13484: # For a given well defined symb, courside, domain, username, 13485: # and course environment, the seed is reproducible. 13486: # 13487: sub rndseed { 13488: my ($symb,$courseid,$domain,$username, $cenv)=@_; 13489: my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); 13490: if (!defined($symb)) { 13491: unless ($symb=$wsymb) { return time; } 13492: } 13493: if (!defined $courseid) { 13494: $courseid=$wcourseid; 13495: } 13496: if (!defined $domain) { $domain=$wdomain; } 13497: if (!defined $username) { $username=$wusername } 13498: 13499: my $which; 13500: if (defined($cenv->{'rndseed'})) { 13501: $which = $cenv->{'rndseed'}; 13502: } else { 13503: $which =&get_rand_alg($courseid); 13504: } 13505: if (defined(&getCODE())) { 13506: 13507: if ($which eq '64bit5') { 13508: return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); 13509: } elsif ($which eq '64bit4') { 13510: return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); 13511: } else { 13512: return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); 13513: } 13514: } elsif ($which eq '64bit5') { 13515: return &rndseed_64bit5($symb,$courseid,$domain,$username); 13516: } elsif ($which eq '64bit4') { 13517: return &rndseed_64bit4($symb,$courseid,$domain,$username); 13518: } elsif ($which eq '64bit3') { 13519: return &rndseed_64bit3($symb,$courseid,$domain,$username); 13520: } elsif ($which eq '64bit2') { 13521: return &rndseed_64bit2($symb,$courseid,$domain,$username); 13522: } elsif ($which eq '64bit') { 13523: return &rndseed_64bit($symb,$courseid,$domain,$username); 13524: } 13525: return &rndseed_32bit($symb,$courseid,$domain,$username); 13526: } 13527: 13528: sub rndseed_32bit { 13529: my ($symb,$courseid,$domain,$username)=@_; 13530: { 13531: use integer; 13532: my $symbchck=unpack("%32C*",$symb) << 27; 13533: my $symbseed=numval($symb) << 22; 13534: my $namechck=unpack("%32C*",$username) << 17; 13535: my $nameseed=numval($username) << 12; 13536: my $domainseed=unpack("%32C*",$domain) << 7; 13537: my $courseseed=unpack("%32C*",$courseid); 13538: my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; 13539: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 13540: #&logthis("rndseed :$num:$symb"); 13541: if ($_64bit) { $num=(($num<<32)>>32); } 13542: return $num; 13543: } 13544: } 13545: 13546: sub rndseed_64bit { 13547: my ($symb,$courseid,$domain,$username)=@_; 13548: { 13549: use integer; 13550: my $symbchck=unpack("%32S*",$symb) << 21; 13551: my $symbseed=numval($symb) << 10; 13552: my $namechck=unpack("%32S*",$username); 13553: 13554: my $nameseed=numval($username) << 21; 13555: my $domainseed=unpack("%32S*",$domain) << 10; 13556: my $courseseed=unpack("%32S*",$courseid); 13557: 13558: my $num1=$symbchck+$symbseed+$namechck; 13559: my $num2=$nameseed+$domainseed+$courseseed; 13560: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 13561: #&logthis("rndseed :$num:$symb"); 13562: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } 13563: return "$num1,$num2"; 13564: } 13565: } 13566: 13567: sub rndseed_64bit2 { 13568: my ($symb,$courseid,$domain,$username)=@_; 13569: { 13570: use integer; 13571: # strings need to be an even # of cahracters long, it it is odd the 13572: # last characters gets thrown away 13573: my $symbchck=unpack("%32S*",$symb.' ') << 21; 13574: my $symbseed=numval($symb) << 10; 13575: my $namechck=unpack("%32S*",$username.' '); 13576: 13577: my $nameseed=numval($username) << 21; 13578: my $domainseed=unpack("%32S*",$domain.' ') << 10; 13579: my $courseseed=unpack("%32S*",$courseid.' '); 13580: 13581: my $num1=$symbchck+$symbseed+$namechck; 13582: my $num2=$nameseed+$domainseed+$courseseed; 13583: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 13584: #&logthis("rndseed :$num:$symb"); 13585: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } 13586: return "$num1,$num2"; 13587: } 13588: } 13589: 13590: sub rndseed_64bit3 { 13591: my ($symb,$courseid,$domain,$username)=@_; 13592: { 13593: use integer; 13594: # strings need to be an even # of cahracters long, it it is odd the 13595: # last characters gets thrown away 13596: my $symbchck=unpack("%32S*",$symb.' ') << 21; 13597: my $symbseed=numval2($symb) << 10; 13598: my $namechck=unpack("%32S*",$username.' '); 13599: 13600: my $nameseed=numval2($username) << 21; 13601: my $domainseed=unpack("%32S*",$domain.' ') << 10; 13602: my $courseseed=unpack("%32S*",$courseid.' '); 13603: 13604: my $num1=$symbchck+$symbseed+$namechck; 13605: my $num2=$nameseed+$domainseed+$courseseed; 13606: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 13607: #&logthis("rndseed :$num1:$num2:$_64bit"); 13608: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } 13609: 13610: return "$num1:$num2"; 13611: } 13612: } 13613: 13614: sub rndseed_64bit4 { 13615: my ($symb,$courseid,$domain,$username)=@_; 13616: { 13617: use integer; 13618: # strings need to be an even # of cahracters long, it it is odd the 13619: # last characters gets thrown away 13620: my $symbchck=unpack("%32S*",$symb.' ') << 21; 13621: my $symbseed=numval3($symb) << 10; 13622: my $namechck=unpack("%32S*",$username.' '); 13623: 13624: my $nameseed=numval3($username) << 21; 13625: my $domainseed=unpack("%32S*",$domain.' ') << 10; 13626: my $courseseed=unpack("%32S*",$courseid.' '); 13627: 13628: my $num1=$symbchck+$symbseed+$namechck; 13629: my $num2=$nameseed+$domainseed+$courseseed; 13630: #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); 13631: #&logthis("rndseed :$num1:$num2:$_64bit"); 13632: if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } 13633: 13634: return "$num1:$num2"; 13635: } 13636: } 13637: 13638: sub rndseed_64bit5 { 13639: my ($symb,$courseid,$domain,$username)=@_; 13640: my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username"); 13641: return "$num1:$num2"; 13642: } 13643: 13644: sub rndseed_CODE_64bit { 13645: my ($symb,$courseid,$domain,$username)=@_; 13646: { 13647: use integer; 13648: my $symbchck=unpack("%32S*",$symb.' ') << 16; 13649: my $symbseed=numval2($symb); 13650: my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; 13651: my $CODEseed=numval(&getCODE()); 13652: my $courseseed=unpack("%32S*",$courseid.' '); 13653: my $num1=$symbseed+$CODEchck; 13654: my $num2=$CODEseed+$courseseed+$symbchck; 13655: #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); 13656: #&logthis("rndseed :$num1:$num2:$symb"); 13657: if ($_64bit) { $num1=(($num1<<32)>>32); } 13658: if ($_64bit) { $num2=(($num2<<32)>>32); } 13659: return "$num1:$num2"; 13660: } 13661: } 13662: 13663: sub rndseed_CODE_64bit4 { 13664: my ($symb,$courseid,$domain,$username)=@_; 13665: { 13666: use integer; 13667: my $symbchck=unpack("%32S*",$symb.' ') << 16; 13668: my $symbseed=numval3($symb); 13669: my $CODEchck=unpack("%32S*",&getCODE().' ') << 16; 13670: my $CODEseed=numval3(&getCODE()); 13671: my $courseseed=unpack("%32S*",$courseid.' '); 13672: my $num1=$symbseed+$CODEchck; 13673: my $num2=$CODEseed+$courseseed+$symbchck; 13674: #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck"); 13675: #&logthis("rndseed :$num1:$num2:$symb"); 13676: if ($_64bit) { $num1=(($num1<<32)>>32); } 13677: if ($_64bit) { $num2=(($num2<<32)>>32); } 13678: return "$num1:$num2"; 13679: } 13680: } 13681: 13682: sub rndseed_CODE_64bit5 { 13683: my ($symb,$courseid,$domain,$username)=@_; 13684: my $code = &getCODE(); 13685: my ($num1,$num2)=&digest("$symb,$courseid,$code"); 13686: return "$num1:$num2"; 13687: } 13688: 13689: sub setup_random_from_rndseed { 13690: my ($rndseed)=@_; 13691: if ($rndseed =~/([,:])/) { 13692: my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed)); 13693: if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) { 13694: &Math::Random::random_set_seed_from_phrase($rndseed); 13695: } else { 13696: &Math::Random::random_set_seed($num1,$num2); 13697: } 13698: } else { 13699: &Math::Random::random_set_seed_from_phrase($rndseed); 13700: } 13701: } 13702: 13703: sub latest_receipt_algorithm_id { 13704: return 'receipt3'; 13705: } 13706: 13707: sub recunique { 13708: my $fucourseid=shift; 13709: my $unique; 13710: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || 13711: $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { 13712: $unique=$env{"course.$fucourseid.internal.encseed"}; 13713: } else { 13714: $unique=$perlvar{'lonReceipt'}; 13715: } 13716: return unpack("%32C*",$unique); 13717: } 13718: 13719: sub recprefix { 13720: my $fucourseid=shift; 13721: my $prefix; 13722: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'|| 13723: $env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { 13724: $prefix=$env{"course.$fucourseid.internal.encpref"}; 13725: } else { 13726: $prefix=$perlvar{'lonHostID'}; 13727: } 13728: return unpack("%32C*",$prefix); 13729: } 13730: 13731: sub ireceipt { 13732: my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; 13733: 13734: my $return =&recprefix($fucourseid).'-'; 13735: 13736: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' || 13737: $env{'request.state'} eq 'construct') { 13738: $return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000); 13739: return $return; 13740: } 13741: 13742: my $cuname=unpack("%32C*",$funame); 13743: my $cudom=unpack("%32C*",$fudom); 13744: my $cucourseid=unpack("%32C*",$fucourseid); 13745: my $cusymb=unpack("%32C*",$fusymb); 13746: my $cunique=&recunique($fucourseid); 13747: my $cpart=unpack("%32S*",$part); 13748: if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { 13749: 13750: #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); 13751: 13752: $return.= ($cunique%$cuname+ 13753: $cunique%$cudom+ 13754: $cusymb%$cuname+ 13755: $cusymb%$cudom+ 13756: $cucourseid%$cuname+ 13757: $cucourseid%$cudom+ 13758: $cpart%$cuname+ 13759: $cpart%$cudom); 13760: } else { 13761: $return.= ($cunique%$cuname+ 13762: $cunique%$cudom+ 13763: $cusymb%$cuname+ 13764: $cusymb%$cudom+ 13765: $cucourseid%$cuname+ 13766: $cucourseid%$cudom); 13767: } 13768: return $return; 13769: } 13770: 13771: sub receipt { 13772: my ($part)=@_; 13773: my ($symb,$courseid,$domain,$name) = &whichuser(); 13774: return &ireceipt($name,$domain,$courseid,$symb,$part); 13775: } 13776: 13777: sub whichuser { 13778: my ($passedsymb)=@_; 13779: my ($symb,$courseid,$domain,$name,$publicuser); 13780: if (defined($env{'form.grade_symb'})) { 13781: my ($tmp_courseid)=&get_env_multiple('form.grade_courseid'); 13782: my $allowed=&allowed('vgr',$tmp_courseid); 13783: if (!$allowed && 13784: exists($env{'request.course.sec'}) && 13785: $env{'request.course.sec'} !~ /^\s*$/) { 13786: $allowed=&allowed('vgr',$tmp_courseid. 13787: '/'.$env{'request.course.sec'}); 13788: } 13789: if ($allowed) { 13790: ($symb)=&get_env_multiple('form.grade_symb'); 13791: $courseid=$tmp_courseid; 13792: ($domain)=&get_env_multiple('form.grade_domain'); 13793: ($name)=&get_env_multiple('form.grade_username'); 13794: return ($symb,$courseid,$domain,$name,$publicuser); 13795: } 13796: } 13797: if (!$passedsymb) { 13798: $symb=&symbread(); 13799: } else { 13800: $symb=$passedsymb; 13801: } 13802: $courseid=$env{'request.course.id'}; 13803: $domain=$env{'user.domain'}; 13804: $name=$env{'user.name'}; 13805: if ($name eq 'public' && $domain eq 'public') { 13806: if (!defined($env{'form.username'})) { 13807: $env{'form.username'}.=time.rand(10000000); 13808: } 13809: $name.=$env{'form.username'}; 13810: } 13811: return ($symb,$courseid,$domain,$name,$publicuser); 13812: 13813: } 13814: 13815: # ------------------------------------------------------------ Serves up a file 13816: # returns either the contents of the file or 13817: # -1 if the file doesn't exist 13818: # 13819: # if the target is a file that was uploaded via DOCS, 13820: # a check will be made to see if a current copy exists on the local server, 13821: # if it does this will be served, otherwise a copy will be retrieved from 13822: # the home server for the course and stored in /home/httpd/html/userfiles on 13823: # the local server. 13824: 13825: sub getfile { 13826: my ($file) = @_; 13827: if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } 13828: &repcopy($file); 13829: return &readfile($file); 13830: } 13831: 13832: sub repcopy_userfile { 13833: my ($file)=@_; 13834: my $londocroot = $perlvar{'lonDocRoot'}; 13835: if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); } 13836: if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; } 13837: my ($cdom,$cnum,$filename) = 13838: ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); 13839: my $uri="/uploaded/$cdom/$cnum/$filename"; 13840: if (-e "$file") { 13841: # we already have a local copy, check it out 13842: my @fileinfo = stat($file); 13843: my $rtncode; 13844: my $info; 13845: my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); 13846: if ($lwpresp ne 'ok') { 13847: # there is no such file anymore, even though we had a local copy 13848: if ($rtncode eq '404') { 13849: unlink($file); 13850: } 13851: return -1; 13852: } 13853: if ($info < $fileinfo[9]) { 13854: # nice, the file we have is up-to-date, just say okay 13855: return 'ok'; 13856: } else { 13857: # the file is outdated, get rid of it 13858: unlink($file); 13859: } 13860: } 13861: # one way or the other, at this point, we don't have the file 13862: # construct the correct path for the file 13863: my @parts = ($cdom,$cnum); 13864: if ($filename =~ m|^(.+)/[^/]+$|) { 13865: push @parts, split(/\//,$1); 13866: } 13867: my $path = $perlvar{'lonDocRoot'}.'/userfiles'; 13868: foreach my $part (@parts) { 13869: $path .= '/'.$part; 13870: if (!-e $path) { 13871: mkdir($path,0770); 13872: } 13873: } 13874: # now the path exists for sure 13875: # get a user agent 13876: my $transferfile=$file.'.in.transfer'; 13877: # FIXME: this should flock 13878: if (-e $transferfile) { return 'ok'; } 13879: my $request; 13880: $uri=~s/^\///; 13881: my $homeserver = &homeserver($cnum,$cdom); 13882: my $hostname = &hostname($homeserver); 13883: my $protocol = $protocol{$homeserver}; 13884: $protocol = 'http' if ($protocol ne 'https'); 13885: $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri); 13886: my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1); 13887: # did it work? 13888: if ($response->is_error()) { 13889: unlink($transferfile); 13890: &logthis("Userfile repcopy failed for $uri"); 13891: return -1; 13892: } 13893: # worked, rename the transfer file 13894: rename($transferfile,$file); 13895: return 'ok'; 13896: } 13897: 13898: sub tokenwrapper { 13899: my $uri=shift; 13900: $uri=~s|^https?\://([^/]+)||; 13901: $uri=~s|^/||; 13902: $env{'user.environment'}=~/\/([^\/]+)\.id/; 13903: my $token=$1; 13904: my (undef,$udom,$uname,$file)=split('/',$uri,4); 13905: if ($udom && $uname && $file) { 13906: $file=~s|(\?\.*)*$||; 13907: &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); 13908: my $homeserver = &homeserver($uname,$udom); 13909: my $hostname = &hostname($homeserver); 13910: my $protocol = $protocol{$homeserver}; 13911: $protocol = 'http' if ($protocol ne 'https'); 13912: return $protocol.'://'.$hostname.'/'.$uri. 13913: (($uri=~/\?/)?'&':'?').'token='.$token. 13914: '&tokenissued='.$perlvar{'lonHostID'}; 13915: } else { 13916: return '/adm/notfound.html'; 13917: } 13918: } 13919: 13920: # call with reqtype HEAD: get last modification time 13921: # call with reqtype GET: get the file contents 13922: # Do not call this with reqtype GET for large files! It loads everything into memory 13923: # 13924: sub getuploaded { 13925: my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; 13926: $uri=~s/^\///; 13927: my $homeserver = &homeserver($cnum,$cdom); 13928: my $hostname = &hostname($homeserver); 13929: my $protocol = $protocol{$homeserver}; 13930: $protocol = 'http' if ($protocol ne 'https'); 13931: $uri = $protocol.'://'.$hostname.'/raw/'.$uri; 13932: my $request=new HTTP::Request($reqtype,$uri); 13933: my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1); 13934: $$rtncode = $response->code; 13935: if (! $response->is_success()) { 13936: return 'failed'; 13937: } 13938: if ($reqtype eq 'HEAD') { 13939: $$info = &HTTP::Date::str2time( $response->header('Last-modified') ); 13940: } elsif ($reqtype eq 'GET') { 13941: $$info = $response->content; 13942: } 13943: return 'ok'; 13944: } 13945: 13946: sub readfile { 13947: my $file = shift; 13948: if ( (! -e $file ) || ($file eq '') ) { return -1; }; 13949: my $fh; 13950: open($fh,"<",$file); 13951: my $a=''; 13952: while (my $line = <$fh>) { $a .= $line; } 13953: return $a; 13954: } 13955: 13956: sub filelocation { 13957: my ($dir,$file) = @_; 13958: my $location; 13959: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces 13960: 13961: if ($file =~ m-^/adm/-) { 13962: $file=~s-^/adm/wrapper/-/-; 13963: $file=~s-^/adm/coursedocs/showdoc/-/-; 13964: } 13965: 13966: if ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) { 13967: $location = $file; 13968: } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file 13969: my ($udom,$uname,$filename)= 13970: ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); 13971: my $home=&homeserver($uname,$udom); 13972: my $is_me=0; 13973: my @ids=&current_machine_ids(); 13974: foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } 13975: if ($is_me) { 13976: $location=propath($udom,$uname).'/userfiles/'.$filename; 13977: } else { 13978: $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. 13979: $udom.'/'.$uname.'/'.$filename; 13980: } 13981: } elsif ($file =~ m-^/adm/-) { 13982: $location = $perlvar{'lonDocRoot'}.'/'.$file; 13983: } else { 13984: $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; 13985: $file=~s:^/(res|priv)/:/:; 13986: my $space=$1; 13987: if ( !( $file =~ m:^/:) ) { 13988: $location = $dir. '/'.$file; 13989: } else { 13990: $location = $perlvar{'lonDocRoot'}.'/'.$space.$file; 13991: } 13992: } 13993: $location=~s://+:/:g; # remove duplicate / 13994: while ($location=~m{/\.\./}) { 13995: if ($location =~ m{/[^/]+/\.\./}) { 13996: $location=~ s{/[^/]+/\.\./}{/}g; 13997: } else { 13998: $location=~ s{/\.\./}{/}g; 13999: } 14000: } #remove dir/.. 14001: while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ 14002: return $location; 14003: } 14004: 14005: sub hreflocation { 14006: my ($dir,$file)=@_; 14007: unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) { 14008: $file=filelocation($dir,$file); 14009: } elsif ($file=~m-^/adm/-) { 14010: $file=~s-^/adm/wrapper/-/-; 14011: $file=~s-^/adm/coursedocs/showdoc/-/-; 14012: } 14013: if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { 14014: $file=~s-^\Q$perlvar{'lonDocRoot'}\E--; 14015: } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { 14016: $file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/} 14017: {/uploaded/$1/$2/}x; 14018: } 14019: if ($file=~ m{^/userfiles/}) { 14020: $file =~ s{^/userfiles/}{/uploaded/}; 14021: } 14022: return $file; 14023: } 14024: 14025: 14026: 14027: 14028: 14029: sub current_machine_domains { 14030: return &machine_domains(&hostname($perlvar{'lonHostID'})); 14031: } 14032: 14033: sub machine_domains { 14034: my ($hostname) = @_; 14035: my @domains; 14036: my %hostname = &all_hostnames(); 14037: while( my($id, $name) = each(%hostname)) { 14038: # &logthis("-$id-$name-$hostname-"); 14039: if ($hostname eq $name) { 14040: push(@domains,&host_domain($id)); 14041: } 14042: } 14043: return @domains; 14044: } 14045: 14046: sub current_machine_ids { 14047: return &machine_ids(&hostname($perlvar{'lonHostID'})); 14048: } 14049: 14050: sub machine_ids { 14051: my ($hostname) = @_; 14052: $hostname ||= &hostname($perlvar{'lonHostID'}); 14053: my @ids; 14054: my %name_to_host = &all_names(); 14055: if (ref($name_to_host{$hostname}) eq 'ARRAY') { 14056: return @{ $name_to_host{$hostname} }; 14057: } 14058: return; 14059: } 14060: 14061: sub additional_machine_domains { 14062: my @domains; 14063: open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab"); 14064: while( my $line = <$fh>) { 14065: $line =~ s/\s//g; 14066: push(@domains,$line); 14067: } 14068: return @domains; 14069: } 14070: 14071: sub default_login_domain { 14072: my $domain = $perlvar{'lonDefDomain'}; 14073: my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0]; 14074: foreach my $posdom (&current_machine_domains(), 14075: &additional_machine_domains()) { 14076: if (lc($posdom) eq lc($testdomain)) { 14077: $domain=$posdom; 14078: last; 14079: } 14080: } 14081: return $domain; 14082: } 14083: 14084: sub shared_institution { 14085: my ($dom) = @_; 14086: my $same_intdom; 14087: my $hostintdom = &internet_dom($perlvar{'lonHostID'}); 14088: if ($hostintdom ne '') { 14089: my %iphost = &get_iphost(); 14090: my $primary_id = &domain($dom,'primary'); 14091: my $primary_ip = &get_host_ip($primary_id); 14092: if (ref($iphost{$primary_ip}) eq 'ARRAY') { 14093: foreach my $id (@{$iphost{$primary_ip}}) { 14094: my $intdom = &internet_dom($id); 14095: if ($intdom eq $hostintdom) { 14096: $same_intdom = 1; 14097: last; 14098: } 14099: } 14100: } 14101: } 14102: return $same_intdom; 14103: } 14104: 14105: sub uses_sts { 14106: my ($ignore_cache) = @_; 14107: my $lonhost = $perlvar{'lonHostID'}; 14108: my $hostname = &hostname($lonhost); 14109: my $sts_on; 14110: if ($protocol{$lonhost} eq 'https') { 14111: my $cachetime = 12*3600; 14112: if (!$ignore_cache) { 14113: ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost); 14114: if (defined($cached)) { 14115: return $sts_on; 14116: } 14117: } 14118: my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html'; 14119: my $request=new HTTP::Request('HEAD',$url); 14120: my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1); 14121: if ($response->is_success) { 14122: my $has_sts = $response->header('Strict-Transport-Security'); 14123: if ($has_sts eq '') { 14124: $sts_on = 0; 14125: } else { 14126: if ($has_sts =~ /\Qmax-age=\E(\d+)/) { 14127: my $maxage = $1; 14128: if ($maxage) { 14129: $sts_on = 1; 14130: } else { 14131: $sts_on = 0; 14132: } 14133: } else { 14134: $sts_on = 0; 14135: } 14136: } 14137: return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime); 14138: } 14139: } 14140: return; 14141: } 14142: 14143: # ------------------------------------------------------------- Declutters URLs 14144: 14145: sub declutter { 14146: my $thisfn=shift; 14147: if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } 14148: unless ($thisfn=~m{^/home/httpd/html/priv/}) { 14149: $thisfn=~s{^/home/httpd/html}{}; 14150: } 14151: $thisfn=~s/^\///; 14152: $thisfn=~s|^adm/wrapper/||; 14153: $thisfn=~s|^adm/coursedocs/showdoc/||; 14154: $thisfn=~s/^res\///; 14155: $thisfn=~s/^priv\///; 14156: unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) { 14157: $thisfn=~s/\?.+$//; 14158: } 14159: return $thisfn; 14160: } 14161: 14162: # ------------------------------------------------------------- Clutter up URLs 14163: 14164: sub clutter { 14165: my $thisfn='/'.&declutter(shift); 14166: if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/} 14167: || $thisfn =~ m{^/adm/(includes|pages)} ) { 14168: $thisfn='/res'.$thisfn; 14169: } 14170: if ($thisfn !~m|^/adm|) { 14171: if ($thisfn =~ m|^/ext/|) { 14172: $thisfn='/adm/wrapper'.$thisfn; 14173: } else { 14174: my ($ext) = ($thisfn =~ /\.(\w+)$/); 14175: my $embstyle=&Apache::loncommon::fileembstyle($ext); 14176: if ($embstyle eq 'ssi' 14177: || ($embstyle eq 'hdn') 14178: || ($embstyle eq 'rat') 14179: || ($embstyle eq 'prv') 14180: || ($embstyle eq 'ign')) { 14181: #do nothing with these 14182: } elsif (($embstyle eq 'img') 14183: || ($embstyle eq 'emb') 14184: || ($embstyle eq 'wrp')) { 14185: $thisfn='/adm/wrapper'.$thisfn; 14186: } elsif ($embstyle eq 'unk' 14187: && $thisfn!~/\.(sequence|page)$/) { 14188: $thisfn='/adm/coursedocs/showdoc'.$thisfn; 14189: } else { 14190: # &logthis("Got a blank emb style"); 14191: } 14192: } 14193: } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { 14194: $thisfn='/adm/wrapper'.$thisfn; 14195: } 14196: return $thisfn; 14197: } 14198: 14199: sub clutter_with_no_wrapper { 14200: my $uri = &clutter(shift); 14201: if ($uri =~ m-^/adm/-) { 14202: $uri =~ s-^/adm/wrapper/-/-; 14203: $uri =~ s-^/adm/coursedocs/showdoc/-/-; 14204: } 14205: return $uri; 14206: } 14207: 14208: sub freeze_escape { 14209: my ($value)=@_; 14210: if (ref($value)) { 14211: $value=&nfreeze($value); 14212: return '__FROZEN__'.&escape($value); 14213: } 14214: return &escape($value); 14215: } 14216: 14217: 14218: sub thaw_unescape { 14219: my ($value)=@_; 14220: if ($value =~ /^__FROZEN__/) { 14221: substr($value,0,10,undef); 14222: $value=&unescape($value); 14223: return &thaw($value); 14224: } 14225: return &unescape($value); 14226: } 14227: 14228: sub correct_line_ends { 14229: my ($result)=@_; 14230: $$result =~s/\r\n/\n/mg; 14231: $$result =~s/\r/\n/mg; 14232: } 14233: # ================================================================ Main Program 14234: 14235: sub goodbye { 14236: &logthis("Starting Shut down"); 14237: #not converted to using infrastruture and probably shouldn't be 14238: &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache)))); 14239: #converted 14240: # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); 14241: &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache)))); 14242: # &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache)))); 14243: # &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache)))); 14244: #1.1 only 14245: # &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache)))); 14246: # &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache)))); 14247: # &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache)))); 14248: # &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache)))); 14249: &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered)))); 14250: &logthis(sprintf("%-20s is %s",'kicks',$kicks)); 14251: &logthis(sprintf("%-20s is %s",'hits',$hits)); 14252: &flushcourselogs(); 14253: &logthis("Shutting down"); 14254: } 14255: 14256: sub get_dns { 14257: my ($url,$func,$ignore_cache,$nocache,$hashref) = @_; 14258: if (!$ignore_cache) { 14259: my ($content,$cached)= 14260: &Apache::lonnet::is_cached_new('dns',$url); 14261: if ($cached) { 14262: &$func($content,$hashref); 14263: return; 14264: } 14265: } 14266: 14267: my %alldns; 14268: if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { 14269: foreach my $dns (<$config>) { 14270: next if ($dns !~ /^\^(\S*)/x); 14271: my $line = $1; 14272: my ($host,$protocol) = split(/:/,$line); 14273: if ($protocol ne 'https') { 14274: $protocol = 'http'; 14275: } 14276: $alldns{$host} = $protocol; 14277: } 14278: close($config); 14279: } 14280: while (%alldns) { 14281: my ($dns) = sort { $b cmp $a } keys(%alldns); 14282: my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); 14283: my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); 14284: delete($alldns{$dns}); 14285: next if ($response->is_error()); 14286: if ($url eq '/adm/dns/loncapaCRL') { 14287: return &$func($response); 14288: } else { 14289: my @content = split("\n",$response->content); 14290: unless ($nocache) { 14291: &do_cache_new('dns',$url,\@content,30*24*60*60); 14292: } 14293: &$func(\@content,$hashref); 14294: return; 14295: } 14296: } 14297: my $which = (split('/',$url,4))[3]; 14298: if ($which eq 'loncapaCRL') { 14299: my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; 14300: if (-e $diskfile) { 14301: &logthis("unable to contact DNS, on disk file $diskfile not updated"); 14302: } else { 14303: &logthis("unable to contact DNS, no on disk file $diskfile available"); 14304: } 14305: } else { 14306: &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); 14307: if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) { 14308: my @content = <$config>; 14309: close($config); 14310: &$func(\@content,$hashref); 14311: } 14312: } 14313: return; 14314: } 14315: 14316: # ------------------------------------------------------Get DNS checksums file 14317: sub parse_dns_checksums_tab { 14318: my ($lines,$hashref) = @_; 14319: my $lonhost = $perlvar{'lonHostID'}; 14320: my $machine_dom = &Apache::lonnet::host_domain($lonhost); 14321: my $loncaparev = &get_server_loncaparev($machine_dom); 14322: my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; 14323: my $webconfdir = '/etc/httpd/conf'; 14324: if ($distro =~ /^(ubuntu|debian)(\d+)$/) { 14325: $webconfdir = '/etc/apache2'; 14326: } elsif ($distro =~ /^sles(\d+)$/) { 14327: if ($1 >= 10) { 14328: $webconfdir = '/etc/apache2'; 14329: } 14330: } elsif ($distro =~ /^suse(\d+\.\d+)$/) { 14331: if ($1 >= 10.0) { 14332: $webconfdir = '/etc/apache2'; 14333: } 14334: } 14335: my ($release,$timestamp) = split(/\-/,$loncaparev); 14336: my (%chksum,%revnum); 14337: if (ref($lines) eq 'ARRAY') { 14338: chomp(@{$lines}); 14339: my $version = shift(@{$lines}); 14340: if ($version eq $release) { 14341: foreach my $line (@{$lines}) { 14342: my ($file,$version,$shasum) = split(/,/,$line); 14343: if ($file =~ m{^/etc/httpd/conf}) { 14344: if ($webconfdir eq '/etc/apache2') { 14345: $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/}; 14346: } 14347: } 14348: $chksum{$file} = $shasum; 14349: $revnum{$file} = $version; 14350: } 14351: if (ref($hashref) eq 'HASH') { 14352: %{$hashref} = ( 14353: sums => \%chksum, 14354: versions => \%revnum, 14355: ); 14356: } 14357: } 14358: } 14359: return; 14360: } 14361: 14362: sub fetch_dns_checksums { 14363: my %checksums; 14364: my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); 14365: my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'}); 14366: my ($release,$timestamp) = split(/\-/,$loncaparev); 14367: &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1, 14368: \%checksums); 14369: return \%checksums; 14370: } 14371: 14372: sub fetch_crl_pemfile { 14373: return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1); 14374: } 14375: 14376: sub save_crl_pem { 14377: my ($response) = @_; 14378: my ($msg,$hadchanges); 14379: if (ref($response)) { 14380: my $now = time; 14381: my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'}; 14382: my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp'; 14383: if (open(my $fh,'>',"$tmpcrl")) { 14384: print $fh $response->content; 14385: close($fh); 14386: if (-e $lonca) { 14387: if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) { 14388: my $check = <PIPE>; 14389: close(PIPE); 14390: chomp($check); 14391: if ($check eq 'verify OK') { 14392: my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; 14393: my $backup; 14394: if (-e $dest) { 14395: if (&File::Copy::move($dest,"$dest.bak")) { 14396: $backup = 'ok'; 14397: } 14398: } 14399: if (&File::Copy::move($tmpcrl,$dest)) { 14400: $msg = 'ok'; 14401: if ($backup) { 14402: my (%oldnums,%newnums); 14403: if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) { 14404: while (<PIPE>) { 14405: $oldnums{(split(/:/))[1]} = 1; 14406: } 14407: close(PIPE); 14408: } 14409: if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) { 14410: while(<PIPE>) { 14411: $newnums{(split(/:/))[1]} = 1; 14412: } 14413: close(PIPE); 14414: } 14415: foreach my $key (sort {$b <=> $a } (keys(%newnums))) { 14416: unless (exists($oldnums{$key})) { 14417: $hadchanges = 1; 14418: last; 14419: } 14420: } 14421: unless ($hadchanges) { 14422: foreach my $key (sort {$b <=> $a } (keys(%oldnums))) { 14423: unless (exists($newnums{$key})) { 14424: $hadchanges = 1; 14425: last; 14426: } 14427: } 14428: } 14429: } 14430: } 14431: } else { 14432: unlink($tmpcrl); 14433: } 14434: } else { 14435: unlink($tmpcrl); 14436: } 14437: } else { 14438: unlink($tmpcrl); 14439: } 14440: } 14441: } 14442: return ($msg,$hadchanges); 14443: } 14444: 14445: # ------------------------------------------------------------ Read domain file 14446: { 14447: my $loaded; 14448: my %domain; 14449: 14450: sub parse_domain_tab { 14451: my ($lines) = @_; 14452: foreach my $line (@$lines) { 14453: next if ($line =~ /^(\#|\s*$ )/x); 14454: 14455: chomp($line); 14456: my ($name,@elements) = split(/:/,$line,9); 14457: my %this_domain; 14458: foreach my $field ('description', 'auth_def', 'auth_arg_def', 14459: 'lang_def', 'city', 'longi', 'lati', 14460: 'primary') { 14461: $this_domain{$field} = shift(@elements); 14462: } 14463: $domain{$name} = \%this_domain; 14464: } 14465: } 14466: 14467: sub reset_domain_info { 14468: undef($loaded); 14469: undef(%domain); 14470: } 14471: 14472: sub load_domain_tab { 14473: my ($ignore_cache,$nocache) = @_; 14474: &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); 14475: my $fh; 14476: if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) { 14477: my @lines = <$fh>; 14478: &parse_domain_tab(\@lines); 14479: } 14480: close($fh); 14481: $loaded = 1; 14482: } 14483: 14484: sub domain { 14485: &load_domain_tab() if (!$loaded); 14486: 14487: my ($name,$what) = @_; 14488: return if ( !exists($domain{$name}) ); 14489: 14490: if (!$what) { 14491: return $domain{$name}{'description'}; 14492: } 14493: return $domain{$name}{$what}; 14494: } 14495: 14496: sub domain_info { 14497: &load_domain_tab() if (!$loaded); 14498: return %domain; 14499: } 14500: 14501: } 14502: 14503: 14504: # ------------------------------------------------------------- Read hosts file 14505: { 14506: my %hostname; 14507: my %hostdom; 14508: my %libserv; 14509: my $loaded; 14510: my %name_to_host; 14511: my %internetdom; 14512: my %LC_dns_serv; 14513: 14514: sub parse_hosts_tab { 14515: my ($file) = @_; 14516: foreach my $configline (@$file) { 14517: next if ($configline =~ /^(\#|\s*$ )/x); 14518: chomp($configline); 14519: if ($configline =~ /^\^/) { 14520: if ($configline =~ /^\^([\w.\-]+)/) { 14521: $LC_dns_serv{$1} = 1; 14522: } 14523: next; 14524: } 14525: my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); 14526: $name=~s/\s//g; 14527: if ($id && $domain && $role && $name) { 14528: if ((exists($hostname{$id})) && ($hostname{$id} ne '')) { 14529: my $curr = $hostname{$id}; 14530: my $skip; 14531: if (ref($name_to_host{$curr}) eq 'ARRAY') { 14532: if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) { 14533: $skip = 1; 14534: } else { 14535: @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}}; 14536: } 14537: } 14538: unless ($skip) { 14539: push(@{$name_to_host{$name}},$id); 14540: } 14541: } else { 14542: push(@{$name_to_host{$name}},$id); 14543: } 14544: $hostname{$id}=$name; 14545: $hostdom{$id}=$domain; 14546: if ($role eq 'library') { $libserv{$id}=$name; } 14547: if (defined($protocol)) { 14548: if ($protocol eq 'https') { 14549: $protocol{$id} = $protocol; 14550: } else { 14551: $protocol{$id} = 'http'; 14552: } 14553: } else { 14554: $protocol{$id} = 'http'; 14555: } 14556: if (defined($intdom)) { 14557: $internetdom{$id} = $intdom; 14558: } 14559: } 14560: } 14561: } 14562: 14563: sub reset_hosts_info { 14564: &purge_remembered(); 14565: &reset_domain_info(); 14566: &reset_hosts_ip_info(); 14567: undef(%internetdom); 14568: undef(%name_to_host); 14569: undef(%hostname); 14570: undef(%hostdom); 14571: undef(%libserv); 14572: undef($loaded); 14573: } 14574: 14575: sub load_hosts_tab { 14576: my ($ignore_cache,$nocache) = @_; 14577: &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); 14578: open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); 14579: my @config = <$config>; 14580: &parse_hosts_tab(\@config); 14581: close($config); 14582: $loaded=1; 14583: } 14584: 14585: sub hostname { 14586: &load_hosts_tab() if (!$loaded); 14587: 14588: my ($lonid) = @_; 14589: return $hostname{$lonid}; 14590: } 14591: 14592: sub all_hostnames { 14593: &load_hosts_tab() if (!$loaded); 14594: 14595: return %hostname; 14596: } 14597: 14598: sub all_names { 14599: my ($ignore_cache,$nocache) = @_; 14600: &load_hosts_tab($ignore_cache,$nocache) if (!$loaded); 14601: 14602: return %name_to_host; 14603: } 14604: 14605: sub all_host_domain { 14606: &load_hosts_tab() if (!$loaded); 14607: return %hostdom; 14608: } 14609: 14610: sub all_host_intdom { 14611: &load_hosts_tab() if (!$loaded); 14612: return %internetdom; 14613: } 14614: 14615: sub is_library { 14616: &load_hosts_tab() if (!$loaded); 14617: 14618: return exists($libserv{$_[0]}); 14619: } 14620: 14621: sub all_library { 14622: &load_hosts_tab() if (!$loaded); 14623: 14624: return %libserv; 14625: } 14626: 14627: sub unique_library { 14628: #2x reverse removes all hostnames that appear more than once 14629: my %unique = reverse &all_library(); 14630: return reverse %unique; 14631: } 14632: 14633: sub get_servers { 14634: &load_hosts_tab() if (!$loaded); 14635: 14636: my ($domain,$type) = @_; 14637: my %possible_hosts = ($type eq 'library') ? %libserv 14638: : %hostname; 14639: my %result; 14640: if (ref($domain) eq 'ARRAY') { 14641: while ( my ($host,$hostname) = each(%possible_hosts)) { 14642: if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) { 14643: $result{$host} = $hostname; 14644: } 14645: } 14646: } else { 14647: while ( my ($host,$hostname) = each(%possible_hosts)) { 14648: if ($hostdom{$host} eq $domain) { 14649: $result{$host} = $hostname; 14650: } 14651: } 14652: } 14653: return %result; 14654: } 14655: 14656: sub get_unique_servers { 14657: my %unique = reverse &get_servers(@_); 14658: return reverse %unique; 14659: } 14660: 14661: sub host_domain { 14662: &load_hosts_tab() if (!$loaded); 14663: 14664: my ($lonid) = @_; 14665: return $hostdom{$lonid}; 14666: } 14667: 14668: sub all_domains { 14669: &load_hosts_tab() if (!$loaded); 14670: 14671: my %seen; 14672: my @uniq = grep(!$seen{$_}++, values(%hostdom)); 14673: return @uniq; 14674: } 14675: 14676: sub internet_dom { 14677: &load_hosts_tab() if (!$loaded); 14678: 14679: my ($lonid) = @_; 14680: return $internetdom{$lonid}; 14681: } 14682: 14683: sub is_LC_dns { 14684: &load_hosts_tab() if (!$loaded); 14685: 14686: my ($hostname) = @_; 14687: return exists($LC_dns_serv{$hostname}); 14688: } 14689: 14690: } 14691: 14692: { 14693: my %iphost; 14694: my %name_to_ip; 14695: my %lonid_to_ip; 14696: 14697: sub get_hosts_from_ip { 14698: my ($ip) = @_; 14699: my %iphosts = &get_iphost(); 14700: if (ref($iphosts{$ip})) { 14701: return @{$iphosts{$ip}}; 14702: } 14703: return; 14704: } 14705: 14706: sub reset_hosts_ip_info { 14707: undef(%iphost); 14708: undef(%name_to_ip); 14709: undef(%lonid_to_ip); 14710: } 14711: 14712: sub get_host_ip { 14713: my ($lonid) = @_; 14714: if (exists($lonid_to_ip{$lonid})) { 14715: return $lonid_to_ip{$lonid}; 14716: } 14717: my $name=&hostname($lonid); 14718: my $ip = gethostbyname($name); 14719: return if (!$ip || length($ip) ne 4); 14720: $ip=inet_ntoa($ip); 14721: $name_to_ip{$name} = $ip; 14722: $lonid_to_ip{$lonid} = $ip; 14723: return $ip; 14724: } 14725: 14726: sub get_iphost { 14727: my ($ignore_cache,$nocache) = @_; 14728: 14729: if (!$ignore_cache) { 14730: if (%iphost) { 14731: return %iphost; 14732: } 14733: my ($ip_info,$cached)= 14734: &Apache::lonnet::is_cached_new('iphost','iphost'); 14735: if ($cached) { 14736: %iphost = %{$ip_info->[0]}; 14737: %name_to_ip = %{$ip_info->[1]}; 14738: %lonid_to_ip = %{$ip_info->[2]}; 14739: return %iphost; 14740: } 14741: } 14742: 14743: # get yesterday's info for fallback 14744: my %old_name_to_ip; 14745: my ($ip_info,$cached)= 14746: &Apache::lonnet::is_cached_new('iphost','iphost'); 14747: if ($cached) { 14748: %old_name_to_ip = %{$ip_info->[1]}; 14749: } 14750: 14751: my %name_to_host = &all_names($ignore_cache,$nocache); 14752: foreach my $name (keys(%name_to_host)) { 14753: my $ip; 14754: if (!exists($name_to_ip{$name})) { 14755: $ip = gethostbyname($name); 14756: if (!$ip || length($ip) ne 4) { 14757: if (defined($old_name_to_ip{$name})) { 14758: $ip = $old_name_to_ip{$name}; 14759: &logthis("Can't find $name defaulting to old $ip"); 14760: } else { 14761: &logthis("Name $name no IP found"); 14762: next; 14763: } 14764: } else { 14765: $ip=inet_ntoa($ip); 14766: } 14767: $name_to_ip{$name} = $ip; 14768: } else { 14769: $ip = $name_to_ip{$name}; 14770: } 14771: foreach my $id (@{ $name_to_host{$name} }) { 14772: $lonid_to_ip{$id} = $ip; 14773: } 14774: push(@{$iphost{$ip}},@{$name_to_host{$name}}); 14775: } 14776: unless ($nocache) { 14777: &do_cache_new('iphost','iphost', 14778: [\%iphost,\%name_to_ip,\%lonid_to_ip], 14779: 48*60*60); 14780: } 14781: 14782: return %iphost; 14783: } 14784: 14785: # 14786: # Given a DNS returns the loncapa host name for that DNS 14787: # 14788: sub host_from_dns { 14789: my ($dns) = @_; 14790: my @hosts; 14791: my $ip; 14792: 14793: if (exists($name_to_ip{$dns})) { 14794: $ip = $name_to_ip{$dns}; 14795: } 14796: if (!$ip) { 14797: $ip = gethostbyname($dns); # Initial translation to IP is in net order. 14798: if (length($ip) == 4) { 14799: $ip = &IO::Socket::inet_ntoa($ip); 14800: } 14801: } 14802: if ($ip) { 14803: @hosts = get_hosts_from_ip($ip); 14804: return $hosts[0]; 14805: } 14806: return undef; 14807: } 14808: 14809: sub get_internet_names { 14810: my ($lonid) = @_; 14811: return if ($lonid eq ''); 14812: my ($idnref,$cached)= 14813: &Apache::lonnet::is_cached_new('internetnames',$lonid); 14814: if ($cached) { 14815: return $idnref; 14816: } 14817: my $ip = &get_host_ip($lonid); 14818: my @hosts = &get_hosts_from_ip($ip); 14819: my %iphost = &get_iphost(); 14820: my (@idns,%seen); 14821: foreach my $id (@hosts) { 14822: my $dom = &host_domain($id); 14823: my $prim_id = &domain($dom,'primary'); 14824: my $prim_ip = &get_host_ip($prim_id); 14825: next if ($seen{$prim_ip}); 14826: if (ref($iphost{$prim_ip}) eq 'ARRAY') { 14827: foreach my $id (@{$iphost{$prim_ip}}) { 14828: my $intdom = &internet_dom($id); 14829: unless (grep(/^\Q$intdom\E$/,@idns)) { 14830: push(@idns,$intdom); 14831: } 14832: } 14833: } 14834: $seen{$prim_ip} = 1; 14835: } 14836: return &do_cache_new('internetnames',$lonid,\@idns,12*60*60); 14837: } 14838: 14839: } 14840: 14841: sub all_loncaparevs { 14842: return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11); 14843: } 14844: 14845: # ---------------------------------------------------------- Read loncaparev table 14846: { 14847: sub load_loncaparevs { 14848: if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { 14849: if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) { 14850: while (my $configline=<$config>) { 14851: chomp($configline); 14852: my ($hostid,$loncaparev)=split(/:/,$configline); 14853: $loncaparevs{$hostid}=$loncaparev; 14854: } 14855: close($config); 14856: } 14857: } 14858: } 14859: } 14860: 14861: # ---------------------------------------------------------- Read serverhostID table 14862: { 14863: sub load_serverhomeIDs { 14864: if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { 14865: if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { 14866: while (my $configline=<$config>) { 14867: chomp($configline); 14868: my ($name,$id)=split(/:/,$configline); 14869: $serverhomeIDs{$name}=$id; 14870: } 14871: close($config); 14872: } 14873: } 14874: } 14875: } 14876: 14877: 14878: BEGIN { 14879: 14880: # ----------------------------------- Read loncapa.conf and loncapa_apache.conf 14881: unless ($readit) { 14882: { 14883: my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); 14884: %perlvar = (%perlvar,%{$configvars}); 14885: } 14886: 14887: 14888: # ------------------------------------------------------ Read spare server file 14889: { 14890: open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab"); 14891: 14892: while (my $configline=<$config>) { 14893: chomp($configline); 14894: if ($configline) { 14895: my ($host,$type) = split(':',$configline,2); 14896: if (!defined($type) || $type eq '') { $type = 'default' }; 14897: push(@{ $spareid{$type} }, $host); 14898: } 14899: } 14900: close($config); 14901: } 14902: # ------------------------------------------------------------ Read permissions 14903: { 14904: open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); 14905: 14906: while (my $configline=<$config>) { 14907: chomp($configline); 14908: if ($configline) { 14909: my ($role,$perm)=split(/ /,$configline); 14910: if ($perm ne '') { $pr{$role}=$perm; } 14911: } 14912: } 14913: close($config); 14914: } 14915: 14916: # -------------------------------------------- Read plain texts for permissions 14917: { 14918: open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab"); 14919: 14920: while (my $configline=<$config>) { 14921: chomp($configline); 14922: if ($configline) { 14923: my ($short,@plain)=split(/:/,$configline); 14924: %{$prp{$short}} = (); 14925: if (@plain > 0) { 14926: $prp{$short}{'std'} = $plain[0]; 14927: for (my $i=1; $i<@plain; $i++) { 14928: $prp{$short}{'alt'.$i} = $plain[$i]; 14929: } 14930: } 14931: } 14932: } 14933: close($config); 14934: } 14935: 14936: # ---------------------------------------------------------- Read package table 14937: { 14938: open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab"); 14939: 14940: while (my $configline=<$config>) { 14941: if ($configline !~ /\S/ || $configline=~/^#/) { next; } 14942: chomp($configline); 14943: my ($short,$plain)=split(/:/,$configline); 14944: my ($pack,$name)=split(/\&/,$short); 14945: if ($plain ne '') { 14946: $packagetab{$pack.'&'.$name.'&name'}=$name; 14947: $packagetab{$short}=$plain; 14948: } 14949: } 14950: close($config); 14951: } 14952: 14953: # ---------------------------------------------------------- Read loncaparev table 14954: 14955: &load_loncaparevs(); 14956: 14957: # ---------------------------------------------------------- Read serverhostID table 14958: 14959: &load_serverhomeIDs(); 14960: 14961: # ---------------------------------------------------------- Read releaseslist XML 14962: { 14963: my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml'; 14964: if (-e $file) { 14965: my $parser = HTML::LCParser->new($file); 14966: while (my $token = $parser->get_token()) { 14967: if ($token->[0] eq 'S') { 14968: my $item = $token->[1]; 14969: my $name = $token->[2]{'name'}; 14970: my $value = $token->[2]{'value'}; 14971: my $valuematch = $token->[2]{'valuematch'}; 14972: my $namematch = $token->[2]{'namematch'}; 14973: if ($item eq 'parameter') { 14974: if (($namematch ne '') || (($name ne '') && ($value ne '' || $valuematch ne ''))) { 14975: my $release = $parser->get_text(); 14976: $release =~ s/(^\s*|\s*$ )//gx; 14977: $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch.':'.$namematch} = $release; 14978: } 14979: } elsif ($item ne '' && $name ne '') { 14980: my $release = $parser->get_text(); 14981: $release =~ s/(^\s*|\s*$ )//gx; 14982: $needsrelease{$item.':'.$name.':'.$value} = $release; 14983: } 14984: } 14985: } 14986: } 14987: } 14988: 14989: # ---------------------------------------------------------- Read managers table 14990: { 14991: if (-e "$perlvar{'lonTabDir'}/managers.tab") { 14992: if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) { 14993: while (my $configline=<$config>) { 14994: chomp($configline); 14995: next if ($configline =~ /^\#/); 14996: if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) { 14997: $managerstab{$configline} = 1; 14998: } 14999: } 15000: close($config); 15001: } 15002: } 15003: } 15004: 15005: # ------------- set up temporary directory 15006: { 15007: $tmpdir = LONCAPA::tempdir(); 15008: 15009: } 15010: 15011: # ------------- set default texengine (domain default overrides this) 15012: { 15013: $deftex = LONCAPA::texengine(); 15014: } 15015: 15016: # ------------- set default minimum length for passwords for internal auth users 15017: { 15018: $passwdmin = LONCAPA::passwd_min(); 15019: } 15020: 15021: $memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], 15022: 'compress_threshold'=> 20_000, 15023: }); 15024: 15025: $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; 15026: $dumpcount=0; 15027: $locknum=0; 15028: 15029: &logtouch(); 15030: &logthis('INFO: Read configuration'); 15031: $readit=1; 15032: { 15033: use integer; 15034: my $test=(2**32)+1; 15035: if ($test != 0) { $_64bit=1; } else { $_64bit=0; } 15036: &logthis(" Detected 64bit platform ($_64bit)"); 15037: } 15038: } 15039: } 15040: 15041: 1; 15042: __END__ 15043: 15044: =pod 15045: 15046: =head1 NAME 15047: 15048: Apache::lonnet - Subroutines to ask questions about things in the network. 15049: 15050: =head1 SYNOPSIS 15051: 15052: Invoked by other LON-CAPA modules, when they need to talk to or about objects in the network. 15053: 15054: &Apache::lonnet::SUBROUTINENAME(ARGUMENTS); 15055: 15056: Common parameters: 15057: 15058: =over 4 15059: 15060: =item * 15061: 15062: $uname : an internal username (if $cname expecting a course Id specifically) 15063: 15064: =item * 15065: 15066: $udom : a domain (if $cdom expecting a course's domain specifically) 15067: 15068: =item * 15069: 15070: $symb : a resource instance identifier 15071: 15072: =item * 15073: 15074: $namespace : the name of a .db file that contains the data needed or 15075: being set. 15076: 15077: =back 15078: 15079: =head1 OVERVIEW 15080: 15081: lonnet provides subroutines which interact with the 15082: lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask 15083: about classes, users, and resources. 15084: 15085: For many of these objects you can also use this to store data about 15086: them or modify them in various ways. 15087: 15088: =head2 Symbs 15089: 15090: To identify a specific instance of a resource, LON-CAPA uses symbols 15091: or "symbs"X<symb>. These identifiers are built from the URL of the 15092: map, the resource number of the resource in the map, and the URL of 15093: the resource itself. The latter is somewhat redundant, but might help 15094: if maps change. 15095: 15096: An example is 15097: 15098: msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem 15099: 15100: The respective map entry is 15101: 15102: <resource id="19" src="/res/msu/korte/tests/part12.problem" 15103: title="Problem 2"> 15104: </resource> 15105: 15106: Symbs are used by the random number generator, as well as to store and 15107: restore data specific to a certain instance of for example a problem. 15108: 15109: =head2 Storing And Retrieving Data 15110: 15111: X<store()>X<cstore()>X<restore()>Three of the most important functions 15112: in C<lonnet.pm> are C<&Apache::lonnet::cstore()>, 15113: C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which 15114: is is the non-critical message twin of cstore. These functions are for 15115: handlers to store a perl hash to a user's permanent data space in an 15116: easy manner, and to retrieve it again on another call. It is expected 15117: that a handler would use this once at the beginning to retrieve data, 15118: and then again once at the end to send only the new data back. 15119: 15120: The data is stored in the user's data directory on the user's 15121: homeserver under the ID of the course. 15122: 15123: The hash that is returned by restore will have all of the previous 15124: value for all of the elements of the hash. 15125: 15126: Example: 15127: 15128: #creating a hash 15129: my %hash; 15130: $hash{'foo'}='bar'; 15131: 15132: #storing it 15133: &Apache::lonnet::cstore(\%hash); 15134: 15135: #changing a value 15136: $hash{'foo'}='notbar'; 15137: 15138: #adding a new value 15139: $hash{'bar'}='foo'; 15140: &Apache::lonnet::cstore(\%hash); 15141: 15142: #retrieving the hash 15143: my %history=&Apache::lonnet::restore(); 15144: 15145: #print the hash 15146: foreach my $key (sort(keys(%history))) { 15147: print("\%history{$key} = $history{$key}"); 15148: } 15149: 15150: Will print out: 15151: 15152: %history{1:foo} = bar 15153: %history{1:keys} = foo:timestamp 15154: %history{1:timestamp} = 990455579 15155: %history{2:bar} = foo 15156: %history{2:foo} = notbar 15157: %history{2:keys} = foo:bar:timestamp 15158: %history{2:timestamp} = 990455580 15159: %history{bar} = foo 15160: %history{foo} = notbar 15161: %history{timestamp} = 990455580 15162: %history{version} = 2 15163: 15164: Note that the special hash entries C<keys>, C<version> and 15165: C<timestamp> were added to the hash. C<version> will be equal to the 15166: total number of versions of the data that have been stored. The 15167: C<timestamp> attribute will be the UNIX time the hash was 15168: stored. C<keys> is available in every historical section to list which 15169: keys were added or changed at a specific historical revision of a 15170: hash. 15171: 15172: B<Warning>: do not store the hash that restore returns directly. This 15173: will cause a mess since it will restore the historical keys as if the 15174: were new keys. I.E. 1:foo will become 1:1:foo etc. 15175: 15176: Calling convention: 15177: 15178: my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname); 15179: &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore); 15180: 15181: For more detailed information, see lonnet specific documentation. 15182: 15183: =head1 RETURN MESSAGES 15184: 15185: =over 4 15186: 15187: =item * B<con_lost>: unable to contact remote host 15188: 15189: =item * B<con_delayed>: unable to contact remote host, message will be delivered 15190: when the connection is brought back up 15191: 15192: =item * B<con_failed>: unable to contact remote host and unable to save message 15193: for later delivery 15194: 15195: =item * B<error:>: an error a occurred, a description of the error follows the : 15196: 15197: =item * B<no_such_host>: unable to fund a host associated with the user/domain 15198: that was requested 15199: 15200: =back 15201: 15202: =head1 PUBLIC SUBROUTINES 15203: 15204: =head2 Session Environment Functions 15205: 15206: =over 4 15207: 15208: =item * 15209: X<appenv()> 15210: B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to 15211: the user envirnoment file, and will be restored for each access this 15212: user makes during this session, also modifies the %env for the current 15213: process. Optional rolesarrayref - if defined contains a reference to an array 15214: of roles which are exempt from the restriction on modifying user.role entries 15215: in the user's environment.db and in %env. 15216: 15217: =item * 15218: X<delenv()> 15219: B<delenv($delthis,$regexp)>: removes all items from the session 15220: environment file that begin with $delthis. If the 15221: optional second arg - $regexp - is true, $delthis is treated as a 15222: regular expression, otherwise \Q$delthis\E is used. 15223: The values are also deleted from the current processes %env. 15224: 15225: =item * get_env_multiple($name) 15226: 15227: gets $name from the %env hash, it seemlessly handles the cases where multiple 15228: values may be defined and end up as an array ref. 15229: 15230: returns an array of values 15231: 15232: =back 15233: 15234: =head2 User Information 15235: 15236: =over 4 15237: 15238: =item * 15239: X<queryauthenticate()> 15240: B<queryauthenticate($uname,$udom)>: try to determine user's current 15241: authentication scheme 15242: 15243: =item * 15244: X<authenticate()> 15245: B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to 15246: authenticate user from domain's lib servers (first use the current 15247: one). C<$upass> should be the users password. 15248: $checkdefauth is optional (value is 1 if a check should be made to 15249: authenticate user using default authentication method, and allow 15250: account creation if username does not have account in the domain). 15251: $clientcancheckhost is optional (value is 1 if checking whether the 15252: server can host will occur on the client side in lonauth.pm). 15253: 15254: =item * 15255: X<homeserver()> 15256: B<homeserver($uname,$udom)>: find the server which has 15257: the user's directory and files (there must be only one), this caches 15258: the answer, and also caches if there is a borken connection. 15259: 15260: =item * 15261: X<idget()> 15262: B<idget($udom,$idsref,$namespace)>: find the usernames behind either 15263: a list of student/employee IDs or clicker IDs 15264: (student/employee IDs are a unique resource in a domain, there must be 15265: only 1 ID per username, and only 1 username per ID in a specific domain). 15266: clickerIDs are not necessarily unique, as students might share clickers. 15267: (returns hash: id=>name,id=>name) 15268: 15269: =item * 15270: X<idrget()> 15271: B<idrget($udom,@unames)>: find the IDs behind a list of 15272: usernames (returns hash: name=>id,name=>id) 15273: 15274: =item * 15275: X<idput()> 15276: B<idput($udom,$idsref,$uhome,$namespace)>: store away a list of 15277: names and associated student/employee IDs or clicker IDs. 15278: 15279: =item * 15280: X<iddel()> 15281: B<iddel($udom,$idshashref,$uhome,$namespace)>: delete unwanted 15282: student/employee ID or clicker ID username look-ups from domain. 15283: The homeserver ($uhome) and namespace ($namespace) are optional. 15284: If no $uhome is provided, it will be determined usig &homeserver() 15285: for each user. If no $namespace is provided, the default is ids. 15286: 15287: =item * 15288: X<updateclickers()> 15289: B<updateclickers($udom,$action,$idshashref,$uhome,$critical)>: update 15290: clicker ID-to-username look-ups in clickers.db on library server. 15291: Permitted actions are add or del (i.e., add or delete). The 15292: clickers.db contains clickerID as keys (escaped), and each corresponding 15293: value is an escaped comma-separated list of usernames (for whom the 15294: library server is the homeserver), who registered that particular ID. 15295: If $critical is true, the update will be sent via &critical, otherwise 15296: &reply() will be used. 15297: 15298: =item * 15299: X<rolesinit()> 15300: B<rolesinit($udom,$username)>: get user privileges. 15301: returns user role, first access and timer interval hashes 15302: 15303: =item * 15304: X<privileged()> 15305: B<privileged($username,$domain)>: returns a true if user has a 15306: privileged and active role (i.e. su or dc), false otherwise. 15307: 15308: =item * 15309: X<getsection()> 15310: B<getsection($udom,$uname,$cname)>: finds the section of student in the 15311: course $cname, return section name/number or '' for "not in course" 15312: and '-1' for "no section" 15313: 15314: =item * 15315: X<userenvironment()> 15316: B<userenvironment($udom,$uname,@what)>: gets the values of the keys 15317: passed in @what from the requested user's environment, returns a hash 15318: 15319: =item * 15320: X<userlog_query()> 15321: B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's 15322: activity.log file. %filters defines filters applied when parsing the 15323: log file. These can be start or end timestamps, or the type of action 15324: - log to look for Login or Logout events, check for Checkin or 15325: Checkout, role for role selection. The response is in the form 15326: timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are 15327: escaped strings of the action recorded in the activity.log file. 15328: 15329: =back 15330: 15331: =head2 User Roles 15332: 15333: =over 4 15334: 15335: =item * 15336: 15337: allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege; 15338: returns codes for allowed actions. 15339: 15340: The first argument is required, all others are optional. 15341: 15342: $priv is the privilege being checked. 15343: $uri contains additional information about what is being checked for access (e.g., 15344: URL, course ID etc.). 15345: $symb is the unique resource instance identifier in a course; if needed, 15346: but not provided, it will be retrieved via a call to &symbread(). 15347: $role is the role for which a priv is being checked (only used if priv is evb). 15348: $clientip is the user's IP address (only used when checking for access to portfolio 15349: files). 15350: $noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This 15351: prevents recursive calls to &allowed. 15352: 15353: F: full access 15354: U,I,K: authentication modes (cxx only) 15355: '': forbidden 15356: 1: user needs to choose course 15357: 2: browse allowed 15358: A: passphrase authentication needed 15359: B: access temporarily blocked because of a blocking event in a course. 15360: D: access blocked because access is required via session initiated via deep-link 15361: 15362: =item * 15363: 15364: constructaccess($url,$setpriv) : check for access to construction space URL 15365: 15366: See if the owner domain and name in the URL match those in the 15367: expected environment. If so, return three element list 15368: ($ownername,$ownerdomain,$ownerhome). 15369: 15370: Otherwise return the null string. 15371: 15372: If second argument 'setpriv' is true, it assigns the privileges, 15373: and returns the same three element list, unless the owner has 15374: blocked "ad hoc" Domain Coordinator access to the Author Space, 15375: in which case the null string is returned. 15376: 15377: =item * 15378: 15379: definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role; 15380: define a custom role rolename set privileges in format of lonTabs/roles.tab 15381: for system, domain, and course level. $uname and $udom are optional (current 15382: user's username and domain will be used when either of $uname or $udom are absent. 15383: 15384: =item * 15385: 15386: plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash 15387: (rolesplain.tab); plain text explanation of a user role term. 15388: $type is Course (default) or Community. 15389: If $forcedefault evaluates to true, text returned will be default 15390: text for $type. Otherwise, if this is a course, the text returned 15391: will be a custom name for the role (if defined in the course's 15392: environment). If no custom name is defined the default is returned. 15393: 15394: =item * 15395: 15396: get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) : 15397: All arguments are optional. Returns a hash of a roles, either for 15398: co-author/assistant author roles for a user's Construction Space 15399: (default), or if $context is 'userroles', roles for the user himself, 15400: In the hash, keys are set to colon-separated $uname,$udom,$role, and 15401: (optionally) if $withsec is true, a fourth colon-separated item - $section. 15402: For each key, value is set to colon-separated start and end times for 15403: the role. If no username and domain are specified, will default to 15404: current user/domain. Types, roles, and roledoms are references to arrays 15405: of role statuses (active, future or previous), roles 15406: (e.g., cc,in, st etc.) and domains of the roles which can be used 15407: to restrict the list of roles reported. If no array ref is 15408: provided for types, will default to return only active roles. 15409: 15410: =item * 15411: 15412: in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if 15413: user: $uname:$udom has a role in the course: $cdom_$cnum. 15414: 15415: Additional optional arguments are: $type (if role checking is to be restricted 15416: to certain user status types -- previous (expired roles), active (currently 15417: available roles) or future (roles available in the future), and 15418: $hideprivileged -- if true will not report course roles for users who 15419: have active Domain Coordinator role in course's domain or in additional 15420: domains (specified in 'Domains to check for privileged users' in course 15421: environment -- set via: Course Settings -> Classlists and staff listing). 15422: 15423: =item * 15424: 15425: privileged($username,$domain,$possdomains,$possroles) : returns 1 if user 15426: $username:$domain is a privileged user (e.g., Domain Coordinator or Super User) 15427: $possdomains and $possroles are optional array refs -- to domains to check and 15428: roles to check. If $possdomains is not specified, a dump will be done of the 15429: users' roles.db to check for a dc or su role in any domain. This can be 15430: time consuming if &privileged is called repeatedly (e.g., when displaying a 15431: classlist), so in such cases, supplying a $possdomains array is preferred, as 15432: this then allows &privileged_by_domain() to be used, which caches the identity 15433: of privileged users, eliminating the need for repeated calls to &dump(). 15434: 15435: =item * 15436: 15437: privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash, 15438: where the outer hash keys are domains specified in the $possdomains array ref, 15439: next inner hash keys are privileged roles specified in the $roles array ref, 15440: and the innermost hash contains key = value pairs for username:domain = end:start 15441: for active or future "privileged" users with that role in that domain. To avoid 15442: repeated dumps of domain roles -- via &get_domain_roles() -- contents of the 15443: innerhash are cached using priv_$role and $dom as the identifiers. 15444: 15445: =back 15446: 15447: =head2 User Modification 15448: 15449: =over 4 15450: 15451: =item * 15452: 15453: assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a 15454: user for the level given by URL. Optional start and end dates (leave empty 15455: string or zero for "no date") 15456: 15457: =item * 15458: 15459: changepass($uname,$udom,$currentpass,$newpass,$server) : attempts to 15460: change a users, password, possible return values are: ok, 15461: pwchange_failure, non_authorized, auth_mode_error, unknown_user, 15462: refused 15463: 15464: =item * 15465: 15466: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication 15467: 15468: =item * 15469: 15470: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene, 15471: $forceid,$desiredhome,$email,$inststatus,$candelete) : 15472: 15473: will update user information (firstname,middlename,lastname,generation, 15474: permanentemail), and if forceid is true, student/employee ID also. 15475: A user's institutional affiliation(s) can also be updated. 15476: User information fields will not be overwritten with empty entries 15477: unless the field is included in the $candelete array reference. 15478: This array is included when a single user is modified via "Manage Users", 15479: or when Autoupdate.pl is run by cron in a domain. 15480: 15481: =item * 15482: 15483: modifystudent 15484: 15485: modify a student's enrollment and identification information. 15486: The course id is resolved based on the current user's environment. 15487: This means the invoking user must be a course coordinator or otherwise 15488: associated with a course. 15489: 15490: This call is essentially a wrapper for lonnet::modifyuser and 15491: lonnet::modify_student_enrollment 15492: 15493: Inputs: 15494: 15495: =over 4 15496: 15497: =item B<$udom> Student's loncapa domain 15498: 15499: =item B<$uname> Student's loncapa login name 15500: 15501: =item B<$uid> Student/Employee ID 15502: 15503: =item B<$umode> Student's authentication mode 15504: 15505: =item B<$upass> Student's password 15506: 15507: =item B<$first> Student's first name 15508: 15509: =item B<$middle> Student's middle name 15510: 15511: =item B<$last> Student's last name 15512: 15513: =item B<$gene> Student's generation 15514: 15515: =item B<$usec> Student's section in course 15516: 15517: =item B<$end> Unix time of the roles expiration 15518: 15519: =item B<$start> Unix time of the roles start date 15520: 15521: =item B<$forceid> If defined, allow $uid to be changed 15522: 15523: =item B<$desiredhome> server to use as home server for student 15524: 15525: =item B<$email> Student's permanent e-mail address 15526: 15527: =item B<$type> Type of enrollment (auto or manual) 15528: 15529: =item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto 15530: 15531: =item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC 15532: 15533: =item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment 15534: 15535: =item B<$context> role change context (shown in User Management Logs display in a course) 15536: 15537: =item B<$inststatus> institutional status of user - : separated string of escaped status types 15538: 15539: =item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class. 15540: 15541: =back 15542: 15543: =item * 15544: 15545: modify_student_enrollment 15546: 15547: Change a student's enrollment status in a class. The environment variable 15548: 'role.request.course' must be defined for this function to proceed. 15549: 15550: Inputs: 15551: 15552: =over 4 15553: 15554: =item $udom, student's domain 15555: 15556: =item $uname, student's name 15557: 15558: =item $uid, student's user id 15559: 15560: =item $first, student's first name 15561: 15562: =item $middle 15563: 15564: =item $last 15565: 15566: =item $gene 15567: 15568: =item $usec 15569: 15570: =item $end 15571: 15572: =item $start 15573: 15574: =item $type 15575: 15576: =item $locktype 15577: 15578: =item $cid 15579: 15580: =item $selfenroll 15581: 15582: =item $context 15583: 15584: =item $credits, number of credits student will earn from this class 15585: 15586: =item $instsec, institutional course section code for student 15587: 15588: =back 15589: 15590: 15591: =item * 15592: 15593: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign 15594: custom role; give a custom role to a user for the level given by URL. Specify 15595: name and domain of role author, and role name 15596: 15597: =item * 15598: 15599: revokerole($udom,$uname,$url,$role) : revoke a role for url 15600: 15601: =item * 15602: 15603: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role 15604: 15605: =back 15606: 15607: =head2 Course Infomation 15608: 15609: =over 4 15610: 15611: =item * 15612: 15613: coursedescription($courseid,$options) : returns a hash of information about the 15614: specified course id, including all environment settings for the 15615: course, the description of the course will be in the hash under the 15616: key 'description' 15617: 15618: $options is an optional parameter that if supplied is a hash reference that controls 15619: what how this function works. It has the following key/values: 15620: 15621: =over 4 15622: 15623: =item freshen_cache 15624: 15625: If defined, and the environment cache for the course is valid, it is 15626: returned in the returned hash. 15627: 15628: =item one_time 15629: 15630: If defined, the last cache time is set to _now_ 15631: 15632: =item user 15633: 15634: If defined, the supplied username is used instead of the current user. 15635: 15636: 15637: =back 15638: 15639: =item * 15640: 15641: resdata($name,$domain,$type,@which) : request for current parameter 15642: setting for a specific $type, where $type is either 'course' or 'user', 15643: @what should be a list of parameters to ask about. This routine caches 15644: answers for 10 minutes. 15645: 15646: =item * 15647: 15648: get_courseresdata($courseid, $domain) : dump the entire course resource 15649: data base, returning a hash that is keyed by the resource name and has 15650: values that are the resource value. I believe that the timestamps and 15651: versions are also returned. 15652: 15653: get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's 15654: supplemental content area. This routine caches the number of files for 15655: 10 minutes. 15656: 15657: =back 15658: 15659: =head2 Course Modification 15660: 15661: =over 4 15662: 15663: =item * 15664: 15665: writecoursepref($courseid,%prefs) : write preferences (environment 15666: database) for a course 15667: 15668: =item * 15669: 15670: createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course 15671: 15672: =item * 15673: 15674: generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community). 15675: 15676: =item * 15677: 15678: is_course($courseid), is_course($cdom, $cnum) 15679: 15680: Accepts either a combined $courseid (in the form of domain_courseid) or the 15681: two component version $cdom, $cnum. It checks if the specified course exists. 15682: 15683: Returns: 15684: undef if the course doesn't exist, otherwise 15685: in scalar context the combined courseid. 15686: in list context the two components of the course identifier, domain and 15687: courseid. 15688: 15689: =back 15690: 15691: =head2 Bubblesheet Configuration 15692: 15693: =over 4 15694: 15695: =item * 15696: 15697: get_scantron_config($which) 15698: 15699: $which - the name of the configuration to parse from the file. 15700: 15701: Parses and returns the bubblesheet configuration line selected as a 15702: hash of configuration file fields. 15703: 15704: 15705: Returns: 15706: If the named configuration is not in the file, an empty 15707: hash is returned. 15708: 15709: a hash with the fields 15710: name - internal name for the this configuration setup 15711: description - text to display to operator that describes this config 15712: CODElocation - if 0 or the string 'none' 15713: - no CODE exists for this config 15714: if -1 || the string 'letter' 15715: - a CODE exists for this config and is 15716: a string of letters 15717: Unsupported value (but planned for future support) 15718: if a positive integer 15719: - The CODE exists as the first n items from 15720: the question section of the form 15721: if the string 'number' 15722: - The CODE exists for this config and is 15723: a string of numbers 15724: CODEstart - (only matter if a CODE exists) column in the line where 15725: the CODE starts 15726: CODElength - length of the CODE 15727: IDstart - column where the student/employee ID starts 15728: IDlength - length of the student/employee ID info 15729: Qstart - column where the information from the bubbled 15730: 'questions' start 15731: Qlength - number of columns comprising a single bubble line from 15732: the sheet. (usually either 1 or 10) 15733: Qon - either a single character representing the character used 15734: to signal a bubble was chosen in the positional setup, or 15735: the string 'letter' if the letter of the chosen bubble is 15736: in the final, or 'number' if a number representing the 15737: chosen bubble is in the file (1->A 0->J) 15738: Qoff - the character used to represent that a bubble was 15739: left blank 15740: PaperID - if the scanning process generates a unique number for each 15741: sheet scanned the column that this ID number starts in 15742: PaperIDlength - number of columns that comprise the unique ID number 15743: for the sheet of paper 15744: FirstName - column that the first name starts in 15745: FirstNameLength - number of columns that the first name spans 15746: LastName - column that the last name starts in 15747: LastNameLength - number of columns that the last name spans 15748: BubblesPerRow - number of bubbles available in each row used to 15749: bubble an answer. (If not specified, 10 assumed). 15750: 15751: 15752: =item * 15753: 15754: get_scantronformat_file($cdom) 15755: 15756: $cdom - the course's domain (optional); if not supplied, uses 15757: domain for current $env{'request.course.id'}. 15758: 15759: Returns an array containing lines from the scantron format file for 15760: the domain of the course. 15761: 15762: If a url for a custom.tab file is listed in domain's configuration.db, 15763: lines are from this file. 15764: 15765: Otherwise, if a default.tab has been published in RES space by the 15766: domainconfig user, lines are from this file. 15767: 15768: Otherwise, fall back to getting lines from the legacy file on the 15769: local server: /home/httpd/lonTabs/default_scantronformat.tab 15770: 15771: =back 15772: 15773: =head2 Resource Subroutines 15774: 15775: =over 4 15776: 15777: =item * 15778: 15779: subscribe($fname) : subscribe to a resource, returns URL if possible (probably should use repcopy instead) 15780: 15781: =item * 15782: 15783: repcopy($filename) : subscribes to the requested file, and attempts to 15784: replicate from the owning library server, Might return 15785: 'unavailable', 'not_found', 'forbidden', 'ok', or 15786: 'bad_request', also attempts to grab the metadata for the 15787: resource. Expects the local filesystem pathname 15788: (/home/httpd/html/res/....) 15789: 15790: =back 15791: 15792: =head2 Resource Information 15793: 15794: =over 4 15795: 15796: =item * 15797: 15798: EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates 15799: and returns the value of a variety of different possible values, 15800: $varname should be a request string, and the other parameters can be 15801: used to specify who and what one is asking about. Ordinarily, $cid 15802: does not need to be specified, as it is retrived from 15803: $env{'request.course.id'}, but &Apache::lonnet::EXT() is called 15804: within lonuserstate::loadmap() when initializing a course, before 15805: $env{'request.course.id'} has been set, so it needs to be provided 15806: in that one case. 15807: 15808: Possible values for $varname are environment.lastname (or other item 15809: from the envirnment hash), user.name (or someother aspect about the 15810: user), resource.0.maxtries (or some other part and parameter of a 15811: resource) 15812: 15813: =item * 15814: 15815: directcondval($number) : get current value of a condition; reads from a state 15816: string 15817: 15818: =item * 15819: 15820: condval($condidx) : value of condition index based on state 15821: 15822: =item * 15823: 15824: metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a 15825: resource's metadata, $what should be either a specific key, or either 15826: 'keys' (to get a list of possible keys) or 'packages' to get a list of 15827: packages that this resource currently uses, the last 3 arguments are 15828: only used internally for recursive metadata. 15829: 15830: the toolsymb is only used where the uri is for an external tool (for which 15831: the uri as well as the symb are guaranteed to be unique). 15832: 15833: this function automatically caches all requests except any made recursively 15834: to retrieve a list of metadata keys for an imported library file ($liburi is 15835: defined). 15836: 15837: =item * 15838: 15839: metadata_query($query,$custom,$customshow) : make a metadata query against the 15840: network of library servers; returns file handle of where SQL and regex results 15841: will be stored for query 15842: 15843: =item * 15844: 15845: symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) : 15846: return symbolic list entry (all arguments optional). 15847: 15848: Args: filename is the filename (including path) for the file for which a symb 15849: is required; donotrecurse, if true will prevent calls to allowed() being made 15850: to check access status if more than one resource was found in the bighash 15851: (see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of 15852: a randompick); ignorecachednull, if true will prevent a symb of '' being 15853: returned if $env{$cache_str} is defined as ''; checkforblock if true will 15854: cause possible symbs to be checked to determine if they are subject to content 15855: blocking, if so they will not be included as possible symbs; possibles is a 15856: ref to a hash, which, as a side effect, will be populated with all possible 15857: symbs (content blocking not tested). 15858: 15859: returns the data handle 15860: 15861: =item * 15862: 15863: symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists 15864: and is a possible symb for the URL in $thisfn, and if is an encrypted 15865: resource that the user accessed using /enc/ returns a 1 on success, 0 15866: on failure, user must be in a course, as it assumes the existence of 15867: the course initial hash, and uses $env('request.course.id'}. The third 15868: arg is an optional reference to a scalar. If this arg is passed in the 15869: call to symbverify, it will be set to 1 if the symb has been set to be 15870: encrypted; otherwise it will be null. 15871: 15872: =item * 15873: 15874: symbclean($symb) : removes versions numbers from a symb, returns the 15875: cleaned symb 15876: 15877: =item * 15878: 15879: is_on_map($uri) : checks if the $uri is somewhere on the current 15880: course map, user must be in a course for it to work. 15881: 15882: =item * 15883: 15884: numval($salt) : return random seed value (addend for rndseed) 15885: 15886: =item * 15887: 15888: rndseed($symb,$courseid,$udom,$uname) : create a random sum; returns 15889: a random seed, all arguments are optional, if they aren't sent it uses the 15890: environment to derive them. Note: if symb isn't sent and it can't get one 15891: from &symbread it will use the current time as its return value 15892: 15893: =item * 15894: 15895: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique, 15896: unfakeable, receipt 15897: 15898: =item * 15899: 15900: receipt() : API to ireceipt working off of env values; given out to users 15901: 15902: =item * 15903: 15904: countacc($url) : count the number of accesses to a given URL 15905: 15906: =item * 15907: 15908: checkout($symb,$tuname,$tudom,$tcrsid) : creates a record of a user having looked at an item, most likely printed out or otherwise using a resource 15909: 15910: =item * 15911: 15912: checkin($token) : updates that a resource has beeen returned (a hard copy version for instance) and returns the data that $token was Checkout with ($symb, $tuname, $tudom, and $tcrsid) 15913: 15914: =item * 15915: 15916: expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet 15917: 15918: =item * 15919: 15920: devalidate($symb) : devalidate temporary spreadsheet calculations, 15921: forcing spreadsheet to reevaluate the resource scores next time. 15922: 15923: =item * 15924: 15925: can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource, 15926: when viewing in course context. 15927: 15928: input: six args -- filename (decluttered), course number, course domain, 15929: url, symb (if registered) and group (if this is a 15930: group item -- e.g., bulletin board, group page etc.). 15931: 15932: output: array of five scalars -- 15933: $cfile -- url for file editing if editable on current server 15934: $home -- homeserver of resource (i.e., for author if published, 15935: or course if uploaded.). 15936: $switchserver -- 1 if server switch will be needed. 15937: $forceedit -- 1 if icon/link should be to go to edit mode 15938: $forceview -- 1 if icon/link should be to go to view mode 15939: 15940: =item * 15941: 15942: is_course_upload($file,$cnum,$cdom) 15943: 15944: Used in course context to determine if current file was uploaded to 15945: the course (i.e., would be found in /userfiles/docs on the course's 15946: homeserver. 15947: 15948: input: 3 args -- filename (decluttered), course number and course domain. 15949: output: boolean -- 1 if file was uploaded. 15950: 15951: =back 15952: 15953: =head2 Storing/Retreiving Data 15954: 15955: =over 4 15956: 15957: =item * 15958: 15959: store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash 15960: permanently for this url; hashref needs to be given and should be a \%hashname; 15961: the remaining args aren't required and if they aren't passed or are '' they will 15962: be derived from the env (with the exception of $laststore, which is an 15963: optional arg used when a user's submission is stored in grading). 15964: $laststore is $version=$timestamp, where $version is the most recent version 15965: number retrieved for the corresponding $symb in the $namespace db file, and 15966: $timestamp is the timestamp for that transaction (UNIX time). 15967: $laststore is currently only passed when cstore() is called by 15968: structuretags::finalize_storage(). 15969: 15970: =item * 15971: 15972: cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store 15973: but uses critical subroutine 15974: 15975: =item * 15976: 15977: restore($symb,$namespace,$udom,$uname) : returns hash for this symb; 15978: all args are optional 15979: 15980: =item * 15981: 15982: dumpstore($namespace,$udom,$uname,$regexp,$range) : 15983: dumps the complete (or key matching regexp) namespace into a hash 15984: ($udom, $uname, $regexp, $range are optional) for a namespace that is 15985: normally &store()ed into 15986: 15987: $range should be either an integer '100' (give me the first 100 15988: matching records) 15989: or be two integers sperated by a - with no spaces 15990: '30-50' (give me the 30th through the 50th matching 15991: records) 15992: 15993: 15994: =item * 15995: 15996: putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) : 15997: replaces a &store() version of data with a replacement set of data 15998: for a particular resource in a namespace passed in the $storehash hash 15999: reference. If $tolog is true, the transaction is logged in the courselog 16000: with an action=PUTSTORE. 16001: 16002: =item * 16003: 16004: tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that 16005: works very similar to store/cstore, but all data is stored in a 16006: temporary location and can be reset using tmpreset, $storehash should 16007: be a hash reference, returns nothing on success 16008: 16009: =item * 16010: 16011: tmprestore($symb,$namespace,$udom,$uname) : storage that works very 16012: similar to restore, but all data is stored in a temporary location and 16013: can be reset using tmpreset. Returns a hash of values on success, 16014: error string otherwise. 16015: 16016: =item * 16017: 16018: tmpreset($symb,$namespace,$udom,$uname) : temporary storage reset, 16019: deltes all keys for $symb form the temporary storage hash. 16020: 16021: =item * 16022: 16023: get($namespace,$storearr,$udom,$uname) : returns hash with keys from array 16024: reference filled in from namesp ($udom and $uname are optional) 16025: 16026: =item * 16027: 16028: del($namespace,$storearr,$udom,$uname) : deletes keys out of array from 16029: namesp ($udom and $uname are optional) 16030: 16031: =item * 16032: 16033: dump($namespace,$udom,$uname,$regexp,$range) : 16034: dumps the complete (or key matching regexp) namespace into a hash 16035: ($udom, $uname, $regexp, $range are optional) 16036: 16037: $range should be either an integer '100' (give me the first 100 16038: matching records) 16039: or be two integers sperated by a - with no spaces 16040: '30-50' (give me the 30th through the 50th matching 16041: records) 16042: =item * 16043: 16044: inc($namespace,$store,$udom,$uname) : increments $store in $namespace. 16045: $store can be a scalar, an array reference, or if the amount to be 16046: incremented is > 1, a hash reference. 16047: 16048: ($udom and $uname are optional) 16049: 16050: =item * 16051: 16052: put($namespace,$storehash,$udom,$uname) : stores hash in namesp 16053: ($udom and $uname are optional) 16054: 16055: =item * 16056: 16057: cput($namespace,$storehash,$udom,$uname) : critical put 16058: ($udom and $uname are optional) 16059: 16060: =item * 16061: 16062: newput($namespace,$storehash,$udom,$uname) : 16063: 16064: Attempts to store the items in the $storehash, but only if they don't 16065: currently exist, if this succeeds you can be certain that you have 16066: successfully created a new key value pair in the $namespace db. 16067: 16068: 16069: Args: 16070: $namespace: name of database to store values to 16071: $storehash: hashref to store to the db 16072: $udom: (optional) domain of user containing the db 16073: $uname: (optional) name of user caontaining the db 16074: 16075: Returns: 16076: 'ok' -> succeeded in storing all keys of $storehash 16077: 'key_exists: <key>' -> failed to anything out of $storehash, as at 16078: least <key> already existed in the db (other 16079: requested keys may also already exist) 16080: 'error: <msg>' -> unable to tie the DB or other error occurred 16081: 'con_lost' -> unable to contact request server 16082: 'refused' -> action was not allowed by remote machine 16083: 16084: 16085: =item * 16086: 16087: eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array 16088: reference filled in from namesp (encrypts the return communication) 16089: ($udom and $uname are optional) 16090: 16091: =item * 16092: 16093: log($udom,$name,$home,$message) : write to permanent log for user; use 16094: critical subroutine 16095: 16096: =item * 16097: 16098: get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from 16099: array reference filled in from namespace found in domain level on either 16100: specified domain server ($uhome) or primary domain server ($udom and $uhome are optional). 16101: 16102: =item * 16103: 16104: put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at 16105: domain level either on specified domain server ($uhome) or primary domain 16106: server ($udom and $uhome are optional) 16107: 16108: =item * 16109: 16110: get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults 16111: for: authentication, language, quotas, timezone, date locale, and portal URL in 16112: the target domain. 16113: 16114: May also include additional key => value pairs for the following groups: 16115: 16116: =over 16117: 16118: =item 16119: disk quotas (MB allocated by default to portfolios and authoring spaces). 16120: 16121: =over 16122: 16123: =item defaultquota, authorquota 16124: 16125: =back 16126: 16127: =item 16128: tools (availability of aboutme page, blog, webDAV access for authoring spaces, 16129: portfolio for users). 16130: 16131: =over 16132: 16133: =item 16134: aboutme, blog, webdav, portfolio 16135: 16136: =back 16137: 16138: =item 16139: requestcourses: ability to request courses, and how requests are processed. 16140: 16141: =over 16142: 16143: =item 16144: official, unofficial, community, textbook, placement 16145: 16146: =back 16147: 16148: =item 16149: inststatus: types of institutional affiliation, and order in which they are displayed. 16150: 16151: =over 16152: 16153: =item 16154: inststatustypes, inststatusorder, inststatusguest 16155: 16156: =back 16157: 16158: =item 16159: coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB) 16160: for course's uploaded content. 16161: 16162: =over 16163: 16164: =item 16165: canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, 16166: communityquota, textbookquota, placementquota 16167: 16168: =back 16169: 16170: =item 16171: usersessions: set options for hosting of your users in other domains, and hosting of users from other domains 16172: on your servers. 16173: 16174: =over 16175: 16176: =item 16177: remotesessions, hostedsessions 16178: 16179: =back 16180: 16181: =back 16182: 16183: In cases where a domain coordinator has never used the "Set Domain Configuration" 16184: utility to create a configuration.db file on a domain's primary library server 16185: only the following domain defaults: auth_def, auth_arg_def, lang_def 16186: -- corresponding values are authentication type (internal, krb4, krb5, 16187: or localauth), initial password or a kerberos realm, language (e.g., en-us) -- 16188: will be available. Values are retrieved from cache (if current), unless the 16189: optional $ignore_cache arg is true, or from domain's configuration.db (if available), 16190: or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab. 16191: 16192: Typical usage: 16193: 16194: %domdefaults = &get_domain_defaults($target_domain); 16195: 16196: =back 16197: 16198: =head2 Network Status Functions 16199: 16200: =over 4 16201: 16202: =item * 16203: 16204: dirlist() : return directory list based on URI (first arg). 16205: 16206: Inputs: 1 required, 5 optional. 16207: 16208: =over 16209: 16210: =item 16211: $uri - path to file in filesystem (starts: /res or /userfiles/). Required. 16212: 16213: =item 16214: $userdomain - domain of user/course to be listed. Extracted from $uri if absent. 16215: 16216: =item 16217: $username - username of user/course to be listed. Extracted from $uri if absent. 16218: 16219: =item 16220: $getpropath - boolean: 1 if prepend path using &propath(). 16221: 16222: =item 16223: $getuserdir - boolean: 1 if prepend path for "userfiles". 16224: 16225: =item 16226: $alternateRoot - path to prepend in place of path from $uri. 16227: 16228: =back 16229: 16230: Returns: Array of up to two items. 16231: 16232: =over 16233: 16234: a reference to an array of files/subdirectories 16235: 16236: =over 16237: 16238: Each element in the array of files/subdirectories is a & separated list of 16239: item name and the result of running stat on the item. If dirlist was requested 16240: for a file instead of a directory, the item name will be ''. For a directory 16241: listing, if the item is a metadata file, the element will end &N&M 16242: (where N amd M are either 0 or 1, corresponding to obsolete set (1), or 16243: default copyright set (1). 16244: 16245: =back 16246: 16247: a scalar containing error condition (if encountered). 16248: 16249: =over 16250: 16251: =item 16252: no_host (no homeserver identified for $username:$domain). 16253: 16254: =item 16255: no_such_host (server contacted for listing not identified as valid host). 16256: 16257: =item 16258: con_lost (connection to remote server failed). 16259: 16260: =item 16261: refused (invalid $username:$domain received on lond side). 16262: 16263: =item 16264: no_such_dir (directory at specified path on lond side does not exist). 16265: 16266: =item 16267: empty (directory at specified path on lond side is empty). 16268: 16269: =over 16270: 16271: This is currently not encountered because the &ls3, &ls2, 16272: &ls (_handler) routines on the lond side do not filter out 16273: . and .. from a directory listing. 16274: 16275: =back 16276: 16277: =back 16278: 16279: =back 16280: 16281: =item * 16282: 16283: spareserver() : find server with least workload from spare.tab 16284: 16285: 16286: =item * 16287: 16288: host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef 16289: if there is no corresponding loncapa host. 16290: 16291: =back 16292: 16293: 16294: =head2 Apache Request 16295: 16296: =over 4 16297: 16298: =item * 16299: 16300: ssi($url,%hash) : server side include, does a complete request cycle on url to 16301: localhost, posts hash 16302: 16303: =back 16304: 16305: =head2 Data to String to Data 16306: 16307: =over 4 16308: 16309: =item * 16310: 16311: hash2str(%hash) : convert a hash into a string complete with escaping and '=' 16312: and '&' separators, supports elements that are arrayrefs and hashrefs 16313: 16314: =item * 16315: 16316: hashref2str($hashref) : convert a hashref into a string complete with 16317: escaping and '=' and '&' separators, supports elements that are 16318: arrayrefs and hashrefs 16319: 16320: =item * 16321: 16322: arrayref2str($arrayref) : convert an arrayref into a string complete 16323: with escaping and '&' separators, supports elements that are arrayrefs 16324: and hashrefs 16325: 16326: =item * 16327: 16328: str2hash($string) : convert string to hash using unescaping and 16329: splitting on '=' and '&', supports elements that are arrayrefs and 16330: hashrefs 16331: 16332: =item * 16333: 16334: str2array($string) : convert string to hash using unescaping and 16335: splitting on '&', supports elements that are arrayrefs and hashrefs 16336: 16337: =back 16338: 16339: =head2 Logging Routines 16340: 16341: 16342: These routines allow one to make log messages in the lonnet.log and 16343: lonnet.perm logfiles. 16344: 16345: =over 4 16346: 16347: =item * 16348: 16349: logtouch() : make sure the logfile, lonnet.log, exists 16350: 16351: =item * 16352: 16353: logthis() : append message to the normal lonnet.log file, it gets 16354: preiodically rolled over and deleted. 16355: 16356: =item * 16357: 16358: logperm() : append a permanent message to lonnet.perm.log, this log 16359: file never gets deleted by any automated portion of the system, only 16360: messages of critical importance should go in here. 16361: 16362: 16363: =back 16364: 16365: =head2 General File Helper Routines 16366: 16367: =over 4 16368: 16369: =item * 16370: 16371: getfile($file,$caller) : two cases - requests for files in /res or in /uploaded. 16372: (a) files in /uploaded 16373: (i) If a local copy of the file exists - 16374: compares modification date of local copy with last-modified date for 16375: definitive version stored on home server for course. If local copy is 16376: stale, requests a new version from the home server and stores it. 16377: If the original has been removed from the home server, then local copy 16378: is unlinked. 16379: (ii) If local copy does not exist - 16380: requests the file from the home server and stores it. 16381: 16382: If $caller is 'uploadrep': 16383: This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase) 16384: for request for files originally uploaded via DOCS. 16385: - returns 'ok' if fresh local copy now available, -1 otherwise. 16386: 16387: Otherwise: 16388: This indicates a call from the content generation phase of the request. 16389: - returns the entire contents of the file or -1. 16390: 16391: (b) files in /res 16392: - returns the entire contents of a file or -1; 16393: it properly subscribes to and replicates the file if neccessary. 16394: 16395: 16396: =item * 16397: 16398: stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file 16399: reference 16400: 16401: returns either a stat() list of data about the file or an empty list 16402: if the file doesn't exist or couldn't find out about it (connection 16403: problems or user unknown) 16404: 16405: =item * 16406: 16407: filelocation($dir,$file) : returns file system location of a file 16408: based on URI; meant to be "fairly clean" absolute reference, $dir is a 16409: directory that relative $file lookups are to looked in ($dir of /a/dir 16410: and a file of ../bob will become /a/bob) 16411: 16412: =item * 16413: 16414: hreflocation($dir,$file) : returns file system location or a URL; same as 16415: filelocation except for hrefs 16416: 16417: =item * 16418: 16419: declutter() : declutters URLs -- remove beginning slashes, 'res' etc. 16420: also removes beginning /home/httpd/html unless /priv/ follows it. 16421: 16422: =back 16423: 16424: =head2 Usererfile file routines (/uploaded*) 16425: 16426: =over 4 16427: 16428: =item * 16429: 16430: userfileupload(): main rotine for putting a file in a user or course's 16431: filespace, arguments are, 16432: 16433: formname - required - this is the name of the element in $env where the 16434: filename, and the contents of the file to create/modifed exist 16435: the filename is in $env{'form.'.$formname.'.filename'} and the 16436: contents of the file is located in $env{'form.'.$formname} 16437: context - if coursedoc, store the file in the course of the active role 16438: of the current user; 16439: if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp 16440: if 'canceloverwrite': delete file in tmp/overwrites directory 16441: subdir - required - subdirectory to put the file in under ../userfiles/ 16442: if undefined, it will be placed in "unknown" 16443: 16444: (This routine calls clean_filename() to remove any dangerous 16445: characters from the filename, and then calls finuserfileupload() to 16446: complete the transaction) 16447: 16448: returns either the url of the uploaded file (/uploaded/....) if successful 16449: and /adm/notfound.html if unsuccessful 16450: 16451: =item * 16452: 16453: clean_filename(): routine for cleaing a filename up for storage in 16454: userfile space, argument is: 16455: 16456: filename - proposed filename 16457: 16458: returns: the new clean filename 16459: 16460: =item * 16461: 16462: finishuserfileupload(): routine that creates and sends the file to 16463: userspace, probably shouldn't be called directly 16464: 16465: docuname: username or courseid of destination for the file 16466: docudom: domain of user/course of destination for the file 16467: formname: same as for userfileupload() 16468: fname: filename (including subdirectories) for the file 16469: parser: if 'parse', will parse (html) file to extract references to objects, links etc. 16470: if hashref, and context is scantron, will convert csv format to standard format 16471: allfiles: reference to hash used to store objects found by parser 16472: codebase: reference to hash used for codebases of java objects found by parser 16473: thumbwidth: width (pixels) of thumbnail to be created for uploaded image 16474: thumbheight: height (pixels) of thumbnail to be created for uploaded image 16475: resizewidth: width to be used to resize image using resizeImage from ImageMagick 16476: resizeheight: height to be used to resize image using resizeImage from ImageMagick 16477: context: if 'overwrite', will move the uploaded file from its temporary location to 16478: userfiles to facilitate overwriting a previously uploaded file with same name. 16479: mimetype: reference to scalar to accommodate mime type determined 16480: from File::MMagic if $parser = parse. 16481: 16482: returns either the url of the uploaded file (/uploaded/....) if successful 16483: and /adm/notfound.html if unsuccessful (or an error message if context 16484: was 'overwrite'). 16485: 16486: 16487: =item * 16488: 16489: renameuserfile(): renames an existing userfile to a new name 16490: 16491: Args: 16492: docuname: username or courseid of destination for the file 16493: docudom: domain of user/course of destination for the file 16494: old: current file name (including any subdirs under userfiles) 16495: new: desired file name (including any subdirs under userfiles) 16496: 16497: =item * 16498: 16499: mkdiruserfile(): creates a directory is a userfiles dir 16500: 16501: Args: 16502: docuname: username or courseid of destination for the file 16503: docudom: domain of user/course of destination for the file 16504: dir: dir to create (including any subdirs under userfiles) 16505: 16506: =item * 16507: 16508: removeuserfile(): removes a file that exists in userfiles 16509: 16510: Args: 16511: docuname: username or courseid of destination for the file 16512: docudom: domain of user/course of destination for the file 16513: fname: filname to delete (including any subdirs under userfiles) 16514: 16515: =item * 16516: 16517: removeuploadedurl(): convience function for removeuserfile() 16518: 16519: Args: 16520: url: a full /uploaded/... url to delete 16521: 16522: =item * 16523: 16524: get_portfile_permissions(): 16525: Args: 16526: domain: domain of user or course contain the portfolio files 16527: user: name of user or num of course contain the portfolio files 16528: Returns: 16529: hashref of a dump of the proper file_permissions.db 16530: 16531: 16532: =item * 16533: 16534: get_access_controls(): 16535: 16536: Args: 16537: current_permissions: the hash ref returned from get_portfile_permissions() 16538: group: (optional) the group you want the files associated with 16539: file: (optional) the file you want access info on 16540: 16541: Returns: 16542: a hash (keys are file names) of hashes containing 16543: keys are: path to file/file_name\0uniqueID:scope_end_start (see below) 16544: values are XML containing access control settings (see below) 16545: 16546: Internal notes: 16547: 16548: access controls are stored in file_permissions.db as key=value pairs. 16549: key -> path to file/file_name\0uniqueID:scope_end_start 16550: where scope -> public,guest,course,group,domains or users. 16551: end -> UNIX time for end of access (0 -> no end date) 16552: start -> UNIX time for start of access 16553: 16554: value -> XML description of access control 16555: <scope type=""> (type =1 of: public,guest,course,group,domains,users"> 16556: <start></start> 16557: <end></end> 16558: 16559: <password></password> for scope type = guest 16560: 16561: <domain></domain> for scope type = course or group 16562: <number></number> 16563: <roles id=""> 16564: <role></role> 16565: <access></access> 16566: <section></section> 16567: <group></group> 16568: </roles> 16569: 16570: <dom></dom> for scope type = domains 16571: 16572: <users> for scope type = users 16573: <user> 16574: <uname></uname> 16575: <udom></udom> 16576: </user> 16577: </users> 16578: </scope> 16579: 16580: Access data is also aggregated for each file in an additional key=value pair: 16581: key -> path to file/file_name\0accesscontrol 16582: value -> reference to hash 16583: hash contains key = value pairs 16584: where key = uniqueID:scope_end_start 16585: value = UNIX time record was last updated 16586: 16587: Used to improve speed of look-ups of access controls for each file. 16588: 16589: Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. 16590: 16591: =item * 16592: 16593: modify_access_controls(): 16594: 16595: Modifies access controls for a portfolio file 16596: Args 16597: 1. file name 16598: 2. reference to hash of required changes, 16599: 3. domain 16600: 4. username 16601: where domain,username are the domain of the portfolio owner 16602: (either a user or a course) 16603: 16604: Returns: 16605: 1. result of additions or updates ('ok' or 'error', with error message). 16606: 2. result of deletions ('ok' or 'error', with error message). 16607: 3. reference to hash of any new or updated access controls. 16608: 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. 16609: key = integer (inbound ID) 16610: value = uniqueID 16611: 16612: =item * 16613: 16614: get_timebased_id(): 16615: 16616: Attempts to get a unique timestamp-based suffix for use with items added to a 16617: course via the Course Editor (e.g., folders, composite pages, 16618: group bulletin boards). 16619: 16620: Args: (first three required; six others optional) 16621: 16622: 1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage, 16623: docssequence, or name of group 16624: 16625: 2. keyid (alphanumeric): name of temporary locking key in hash, 16626: e.g., num, boardids 16627: 16628: 3. namespace: name of gdbm file used to store suffixes already assigned; 16629: file will be named nohist_namespace.db 16630: 16631: 4. cdom: domain of course; default is current course domain from %env 16632: 16633: 5. cnum: course number; default is current course number from %env 16634: 16635: 6. idtype: set to concat if an additional digit is to be appended to the 16636: unix timestamp to form the suffix, if the plain timestamp is already 16637: in use. Default is to not do this, but simply increment the unix 16638: timestamp by 1 until a unique key is obtained. 16639: 16640: 7. who: holder of locking key; defaults to user:domain for user. 16641: 16642: 8. locktries: number of attempts to obtain a lock (sleep of 1s before 16643: retrying); default is 3. 16644: 16645: 9. maxtries: number of attempts to obtain a unique suffix; default is 20. 16646: 16647: Returns: 16648: 16649: 1. suffix obtained (numeric) 16650: 16651: 2. result of deleting locking key (ok if deleted, or lock never obtained) 16652: 16653: 3. error: contains (localized) error message if an error occurred. 16654: 16655: 16656: =back 16657: 16658: =head2 HTTP Helper Routines 16659: 16660: =over 4 16661: 16662: =item * 16663: 16664: escape() : unpack non-word characters into CGI-compatible hex codes 16665: 16666: =item * 16667: 16668: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character 16669: 16670: =back 16671: 16672: =head1 PRIVATE SUBROUTINES 16673: 16674: =head2 Underlying communication routines (Shouldn't call) 16675: 16676: =over 4 16677: 16678: =item * 16679: 16680: subreply() : tries to pass a message to lonc, returns con_lost if incapable 16681: 16682: =item * 16683: 16684: reply() : uses subreply to send a message to remote machine, logs all failures 16685: 16686: =item * 16687: 16688: critical() : passes a critical message to another server; if cannot 16689: get through then place message in connection buffer directory and 16690: returns con_delayed, if incapable of saving message, returns 16691: con_failed 16692: 16693: =item * 16694: 16695: reconlonc() : tries to reconnect lonc client processes. 16696: 16697: =back 16698: 16699: =head2 Resource Access Logging 16700: 16701: =over 4 16702: 16703: =item * 16704: 16705: flushcourselogs() : flush (save) buffer logs and access logs 16706: 16707: =item * 16708: 16709: courselog($what) : save message for course in hash 16710: 16711: =item * 16712: 16713: courseacclog($what) : save message for course using &courselog(). Perform 16714: special processing for specific resource types (problems, exams, quizzes, etc). 16715: 16716: =item * 16717: 16718: goodbye() : flush course logs and log shutting down; it is called in srm.conf 16719: as a PerlChildExitHandler 16720: 16721: =back 16722: 16723: =head2 Other 16724: 16725: =over 4 16726: 16727: =item * 16728: 16729: symblist($mapname,%newhash) : update symbolic storage links 16730: 16731: =back 16732: 16733: =cut 16734: