Annotation of loncom/lond, revision 1.567
1.1 albertel 1: #!/usr/bin/perl
2: # The LearningOnline Network
3: # lond "LON Daemon" Server (port "LOND" 5663)
1.60 www 4: #
1.567 ! raeburn 5: # $Id: lond,v 1.566 2021/03/31 02:19:58 raeburn Exp $
1.60 www 6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
1.167 foxr 13: # the Free Software Foundation; either version 2 of the License, or
1.60 www 14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
1.178 foxr 23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
1.60 www 24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
1.161 foxr 27:
28:
1.60 www 29: # http://www.lon-capa.org/
30: #
1.54 harris41 31:
1.134 albertel 32: use strict;
1.80 harris41 33: use lib '/home/httpd/lib/perl/';
1.325 albertel 34: use LONCAPA;
1.80 harris41 35: use LONCAPA::Configuration;
1.490 droeschl 36: use LONCAPA::Lond;
1.80 harris41 37:
1.532 raeburn 38: use Socket;
1.1 albertel 39: use IO::Socket;
40: use IO::File;
1.126 albertel 41: #use Apache::File;
1.1 albertel 42: use POSIX;
43: use Crypt::IDEA;
1.523 raeburn 44: use HTTP::Request;
1.347 raeburn 45: use Digest::MD5 qw(md5_hex);
1.3 www 46: use GDBM_File;
1.91 albertel 47: use Authen::Krb5;
1.49 albertel 48: use localauth;
1.193 raeburn 49: use localenroll;
1.265 albertel 50: use localstudentphoto;
1.143 foxr 51: use File::Copy;
1.292 albertel 52: use File::Find;
1.200 matthew 53: use LONCAPA::lonlocal;
54: use LONCAPA::lonssl;
1.221 albertel 55: use Fcntl qw(:flock);
1.383 raeburn 56: use Apache::lonnet;
1.472 raeburn 57: use Mail::Send;
1.518 raeburn 58: use Crypt::Eksblowfish::Bcrypt;
59: use Digest::SHA;
60: use Encode;
1.523 raeburn 61: use LONCAPA::LWPReq;
1.1 albertel 62:
1.463 foxr 63: my $DEBUG = 0; # Non zero to enable debug log entries.
1.77 foxr 64:
1.57 www 65: my $status='';
66: my $lastlog='';
67:
1.567 ! raeburn 68: my $VERSION='$Revision: 1.566 $'; #' stupid emacs
1.121 albertel 69: my $remoteVERSION;
1.214 foxr 70: my $currenthostid="default";
1.115 albertel 71: my $currentdomainid;
1.134 albertel 72:
73: my $client;
1.200 matthew 74: my $clientip; # IP address of client.
75: my $clientname; # LonCAPA name of client.
1.448 raeburn 76: my $clientversion; # LonCAPA version running on client.
77: my $clienthomedom; # LonCAPA domain of homeID for client.
1.525 raeburn 78: my $clientintdom; # LonCAPA "internet domain" for client.
1.532 raeburn 79: my $clientsamedom; # LonCAPA domain same for this host
80: # and client.
1.525 raeburn 81: my $clientsameinst; # LonCAPA "internet domain" same for
82: # this host and client.
1.556 raeburn 83: my $clientremoteok; # Current domain permits hosting on client
84: # (not set if host and client share "internet domain").
85: # Values are 0 or 1; 1 if allowed.
86: my %clientprohibited; # Commands from client prohibited for domain's
87: # users.
88:
1.134 albertel 89: my $server;
1.200 matthew 90:
91: my $keymode;
1.198 foxr 92:
1.207 foxr 93: my $cipher; # Cipher key negotiated with client
94: my $tmpsnum = 0; # Id of tmpputs.
95:
1.178 foxr 96: #
97: # Connection type is:
98: # client - All client actions are allowed
99: # manager - only management functions allowed.
100: # both - Both management and client actions are allowed
101: #
1.161 foxr 102:
1.178 foxr 103: my $ConnectionType;
1.161 foxr 104:
1.178 foxr 105: my %managers; # Ip -> manager names
1.161 foxr 106:
1.178 foxr 107: my %perlvar; # Will have the apache conf defined perl vars.
1.134 albertel 108:
1.532 raeburn 109: my %secureconf; # Will have requirements for security
110: # of lond connections
111:
1.545 raeburn 112: my %crlchecked; # Will contain clients for which the client's SSL
113: # has been checked against the cluster's Certificate
114: # Revocation List.
115:
1.480 raeburn 116: my $dist;
117:
1.178 foxr 118: #
1.207 foxr 119: # The hash below is used for command dispatching, and is therefore keyed on the request keyword.
120: # Each element of the hash contains a reference to an array that contains:
121: # A reference to a sub that executes the request corresponding to the keyword.
122: # A flag that is true if the request must be encoded to be acceptable.
123: # A mask with bits as follows:
124: # CLIENT_OK - Set when the function is allowed by ordinary clients
125: # MANAGER_OK - Set when the function is allowed to manager clients.
126: #
127: my $CLIENT_OK = 1;
128: my $MANAGER_OK = 2;
129: my %Dispatcher;
130:
131:
132: #
1.178 foxr 133: # The array below are password error strings."
134: #
135: my $lastpwderror = 13; # Largest error number from lcpasswd.
136: my @passwderrors = ("ok",
1.287 foxr 137: "pwchange_failure - lcpasswd must be run as user 'www'",
138: "pwchange_failure - lcpasswd got incorrect number of arguments",
139: "pwchange_failure - lcpasswd did not get the right nubmer of input text lines",
140: "pwchange_failure - lcpasswd too many simultaneous pwd changes in progress",
141: "pwchange_failure - lcpasswd User does not exist.",
142: "pwchange_failure - lcpasswd Incorrect current passwd",
143: "pwchange_failure - lcpasswd Unable to su to root.",
144: "pwchange_failure - lcpasswd Cannot set new passwd.",
145: "pwchange_failure - lcpasswd Username has invalid characters",
146: "pwchange_failure - lcpasswd Invalid characters in password",
147: "pwchange_failure - lcpasswd User already exists",
148: "pwchange_failure - lcpasswd Something went wrong with user addition.",
149: "pwchange_failure - lcpasswd Password mismatch",
150: "pwchange_failure - lcpasswd Error filename is invalid");
1.97 foxr 151:
152:
1.412 foxr 153: # This array are the errors from lcinstallfile:
154:
155: my @installerrors = ("ok",
156: "Initial user id of client not that of www",
157: "Usage error, not enough command line arguments",
1.500 bisitz 158: "Source filename does not exist",
159: "Destination filename does not exist",
1.412 foxr 160: "Some file operation failed",
161: "Invalid table filename."
162: );
1.207 foxr 163:
164: #
1.525 raeburn 165: # The %trust hash classifies commands according to type of trust
166: # required for execution of the command.
167: #
168: # When clients from a different institution request execution of a
169: # particular command, the trust settings for that institution set
170: # for this domain (or default domain for a multi-domain server) will
171: # be checked to see if running the command is allowed.
172: #
173: # Trust types which depend on the "Trust" domain configuration
174: # for the machine's default domain are:
175: #
176: # content ("Access to this domain's content by others")
177: # shared ("Access to other domain's content by this domain")
178: # enroll ("Enrollment in this domain's courses by others")
179: # coaurem ("Co-author roles for this domain's users elsewhere")
1.552 raeburn 180: # othcoau ("Co-author roles in this domain for others")
1.525 raeburn 181: # domroles ("Domain roles in this domain assignable to others")
182: # catalog ("Course Catalog for this domain displayed elsewhere")
183: # reqcrs ("Requests for creation of courses in this domain by others")
184: # msg ("Users in other domains can send messages to this domain")
185: #
186: # Trust type which depends on the User Session Hosting (remote)
187: # domain configuration for machine's default domain is: "remote".
188: #
189: # Trust types which depend on contents of manager.tab in
190: # /home/httpd/lonTabs is: "manageronly".
191: #
192: # Trust type which requires client to share the same LON-CAPA
193: # "internet domain" (i.e., same institution as this server) is:
194: # "institutiononly".
195: #
196:
197: my %trust = (
198: auth => {remote => 1},
199: autocreatepassword => {remote => 1},
200: autocrsreqchecks => {remote => 1, reqcrs => 1},
201: autocrsrequpdate => {remote => 1},
202: autocrsreqvalidation => {remote => 1},
203: autogetsections => {remote => 1},
204: autoinstcodedefaults => {remote => 1, catalog => 1},
205: autoinstcodeformat => {remote => 1, catalog => 1},
206: autonewcourse => {remote => 1, reqcrs => 1},
207: autophotocheck => {remote => 1, enroll => 1},
208: autophotochoice => {remote => 1},
209: autophotopermission => {remote => 1, enroll => 1},
210: autopossibleinstcodes => {remote => 1, reqcrs => 1},
211: autoretrieve => {remote => 1, enroll => 1, catalog => 1},
212: autorun => {remote => 1, enroll => 1, reqcrs => 1},
213: autovalidateclass_sec => {catalog => 1},
214: autovalidatecourse => {remote => 1, enroll => 1},
215: autovalidateinstcode => {domroles => 1, remote => 1, enroll => 1},
1.566 raeburn 216: autovalidateinstcrosslist => {remote => 1, enroll => 1},
1.567 ! raeburn 217: autoinstsecreformat => {remote => 1, enroll => 1},
1.525 raeburn 218: changeuserauth => {remote => 1, domroles => 1},
219: chatretr => {remote => 1, enroll => 1},
220: chatsend => {remote => 1, enroll => 1},
221: courseiddump => {remote => 1, domroles => 1, enroll => 1},
222: courseidput => {remote => 1, domroles => 1, enroll => 1},
223: courseidputhash => {remote => 1, domroles => 1, enroll => 1},
224: courselastaccess => {remote => 1, domroles => 1, enroll => 1},
1.561 raeburn 225: coursesessions => {institutiononly => 1},
1.525 raeburn 226: currentauth => {remote => 1, domroles => 1, enroll => 1},
227: currentdump => {remote => 1, enroll => 1},
228: currentversion => {remote=> 1, content => 1},
229: dcmaildump => {remote => 1, domroles => 1},
230: dcmailput => {remote => 1, domroles => 1},
231: del => {remote => 1, domroles => 1, enroll => 1, content => 1},
1.551 raeburn 232: delbalcookie => {institutiononly => 1},
1.560 raeburn 233: delusersession => {institutiononly => 1},
1.525 raeburn 234: deldom => {remote => 1, domroles => 1}, # not currently used
235: devalidatecache => {institutiononly => 1},
236: domroleput => {remote => 1, enroll => 1},
237: domrolesdump => {remote => 1, catalog => 1},
238: du => {remote => 1, enroll => 1},
239: du2 => {remote => 1, enroll => 1},
240: dump => {remote => 1, enroll => 1, domroles => 1},
241: edit => {institutiononly => 1}, #not used currently
242: eget => {remote => 1, domroles => 1, enroll => 1}, #not used currently
1.536 raeburn 243: egetdom => {remote => 1, domroles => 1, enroll => 1, },
1.553 raeburn 244: ekey => {anywhere => 1},
1.525 raeburn 245: exit => {anywhere => 1},
246: fetchuserfile => {remote => 1, enroll => 1},
247: get => {remote => 1, domroles => 1, enroll => 1},
248: getdom => {anywhere => 1},
249: home => {anywhere => 1},
250: iddel => {remote => 1, enroll => 1},
251: idget => {remote => 1, enroll => 1},
252: idput => {remote => 1, domroles => 1, enroll => 1},
253: inc => {remote => 1, enroll => 1},
254: init => {anywhere => 1},
255: inst_usertypes => {remote => 1, domroles => 1, enroll => 1},
256: instemailrules => {remote => 1, domroles => 1},
257: instidrulecheck => {remote => 1, domroles => 1,},
258: instidrules => {remote => 1, domroles => 1,},
259: instrulecheck => {remote => 1, enroll => 1, reqcrs => 1, domroles => 1},
260: instselfcreatecheck => {institutiononly => 1},
261: instuserrules => {remote => 1, enroll => 1, reqcrs => 1, domroles => 1},
262: keys => {remote => 1,},
263: load => {anywhere => 1},
264: log => {anywhere => 1},
265: ls => {remote => 1, enroll => 1, content => 1,},
266: ls2 => {remote => 1, enroll => 1, content => 1,},
267: ls3 => {remote => 1, enroll => 1, content => 1,},
268: makeuser => {remote => 1, enroll => 1, domroles => 1,},
269: mkdiruserfile => {remote => 1, enroll => 1,},
270: newput => {remote => 1, enroll => 1, reqcrs => 1, domroles => 1,},
271: passwd => {remote => 1},
272: ping => {anywhere => 1},
273: pong => {anywhere => 1},
274: pushfile => {manageronly => 1},
275: put => {remote => 1, enroll => 1, domroles => 1, msg => 1, content => 1, shared => 1},
276: putdom => {remote => 1, domroles => 1,},
277: putstore => {remote => 1, enroll => 1},
278: queryreply => {anywhere => 1},
279: querysend => {anywhere => 1},
1.535 raeburn 280: querysend_activitylog => {remote => 1},
281: querysend_allusers => {remote => 1, domroles => 1},
282: querysend_courselog => {remote => 1},
283: querysend_fetchenrollment => {remote => 1},
284: querysend_getinstuser => {remote => 1},
285: querysend_getmultinstusers => {remote => 1},
286: querysend_instdirsearch => {remote => 1, domroles => 1, coaurem => 1},
287: querysend_institutionalphotos => {remote => 1},
288: querysend_portfolio_metadata => {remote => 1, content => 1},
289: querysend_userlog => {remote => 1, domroles => 1},
290: querysend_usersearch => {remote => 1, enroll => 1, coaurem => 1},
1.525 raeburn 291: quit => {anywhere => 1},
292: readlonnetglobal => {institutiononly => 1},
293: reinit => {manageronly => 1}, #not used currently
294: removeuserfile => {remote => 1, enroll => 1},
295: renameuserfile => {remote => 1,},
296: restore => {remote => 1, enroll => 1, reqcrs => 1,},
297: rolesdel => {remote => 1, enroll => 1, domroles => 1, coaurem => 1},
298: rolesput => {remote => 1, enroll => 1, domroles => 1, coaurem => 1},
1.527 raeburn 299: servercerts => {institutiononly => 1},
1.528 raeburn 300: serverdistarch => {anywhere => 1},
1.525 raeburn 301: serverhomeID => {anywhere => 1},
302: serverloncaparev => {anywhere => 1},
303: servertimezone => {remote => 1, enroll => 1},
304: setannounce => {remote => 1, domroles => 1},
305: sethost => {anywhere => 1},
306: store => {remote => 1, enroll => 1, reqcrs => 1,},
307: studentphoto => {remote => 1, enroll => 1},
308: sub => {content => 1,},
1.552 raeburn 309: tmpdel => {institutiononly => 1},
310: tmpget => {institutiononly => 1},
311: tmpput => {remote => 1, othcoau => 1},
1.525 raeburn 312: tokenauthuserfile => {anywhere => 1},
313: unsub => {content => 1,},
314: update => {shared => 1},
1.564 raeburn 315: updatebalcookie => {institutiononly => 1},
1.525 raeburn 316: updateclickers => {remote => 1},
317: userhassession => {anywhere => 1},
318: userload => {anywhere => 1},
319: version => {anywhere => 1}, #not used
320: );
321:
322: #
1.207 foxr 323: # Statistics that are maintained and dislayed in the status line.
324: #
1.212 foxr 325: my $Transactions = 0; # Number of attempted transactions.
326: my $Failures = 0; # Number of transcations failed.
1.207 foxr 327:
328: # ResetStatistics:
329: # Resets the statistics counters:
330: #
331: sub ResetStatistics {
332: $Transactions = 0;
333: $Failures = 0;
334: }
335:
1.200 matthew 336: #------------------------------------------------------------------------
337: #
338: # LocalConnection
339: # Completes the formation of a locally authenticated connection.
340: # This function will ensure that the 'remote' client is really the
341: # local host. If not, the connection is closed, and the function fails.
342: # If so, initcmd is parsed for the name of a file containing the
343: # IDEA session key. The fie is opened, read, deleted and the session
344: # key returned to the caller.
345: #
346: # Parameters:
347: # $Socket - Socket open on client.
348: # $initcmd - The full text of the init command.
349: #
350: # Returns:
351: # IDEA session key on success.
352: # undef on failure.
353: #
354: sub LocalConnection {
355: my ($Socket, $initcmd) = @_;
1.373 albertel 356: Debug("Attempting local connection: $initcmd client: $clientip");
1.277 albertel 357: if($clientip ne "127.0.0.1") {
1.200 matthew 358: &logthis('<font color="red"> LocalConnection rejecting non local: '
1.373 albertel 359: ."$clientip ne 127.0.0.1 </font>");
1.200 matthew 360: close $Socket;
361: return undef;
1.224 foxr 362: } else {
1.200 matthew 363: chomp($initcmd); # Get rid of \n in filename.
364: my ($init, $type, $name) = split(/:/, $initcmd);
365: Debug(" Init command: $init $type $name ");
366:
367: # Require that $init = init, and $type = local: Otherwise
368: # the caller is insane:
369:
370: if(($init ne "init") && ($type ne "local")) {
371: &logthis('<font color = "red"> LocalConnection: caller is insane! '
372: ."init = $init, and type = $type </font>");
373: close($Socket);;
374: return undef;
375:
376: }
377: # Now get the key filename:
378:
379: my $IDEAKey = lonlocal::ReadKeyFile($name);
380: return $IDEAKey;
381: }
382: }
383: #------------------------------------------------------------------------------
384: #
385: # SSLConnection
386: # Completes the formation of an ssh authenticated connection. The
387: # socket is promoted to an ssl socket. If this promotion and the associated
388: # certificate exchange are successful, the IDEA key is generated and sent
389: # to the remote peer via the SSL tunnel. The IDEA key is also returned to
390: # the caller after the SSL tunnel is torn down.
391: #
392: # Parameters:
393: # Name Type Purpose
394: # $Socket IO::Socket::INET Plaintext socket.
395: #
396: # Returns:
397: # IDEA key on success.
398: # undef on failure.
399: #
400: sub SSLConnection {
401: my $Socket = shift;
402:
403: Debug("SSLConnection: ");
404: my $KeyFile = lonssl::KeyFile();
405: if(!$KeyFile) {
406: my $err = lonssl::LastError();
407: &logthis("<font color=\"red\"> CRITICAL"
408: ."Can't get key file $err </font>");
409: return undef;
410: }
411: my ($CACertificate,
412: $Certificate) = lonssl::CertificateFile();
413:
414:
415: # If any of the key, certificate or certificate authority
416: # certificate filenames are not defined, this can't work.
417:
418: if((!$Certificate) || (!$CACertificate)) {
419: my $err = lonssl::LastError();
420: &logthis("<font color=\"red\"> CRITICAL"
421: ."Can't get certificates: $err </font>");
422:
423: return undef;
424: }
425: Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate");
426:
427: # Indicate to our peer that we can procede with
428: # a transition to ssl authentication:
429:
430: print $Socket "ok:ssl\n";
431:
432: Debug("Approving promotion -> ssl");
433: # And do so:
434:
1.545 raeburn 435: my $CRLFile;
436: unless ($crlchecked{$clientname}) {
437: $CRLFile = lonssl::CRLFile();
438: $crlchecked{$clientname} = 1;
439: }
440:
1.200 matthew 441: my $SSLSocket = lonssl::PromoteServerSocket($Socket,
442: $CACertificate,
443: $Certificate,
1.544 raeburn 444: $KeyFile,
1.545 raeburn 445: $clientname,
1.546 raeburn 446: $CRLFile,
447: $clientversion);
1.200 matthew 448: if(! ($SSLSocket) ) { # SSL socket promotion failed.
449: my $err = lonssl::LastError();
450: &logthis("<font color=\"red\"> CRITICAL "
451: ."SSL Socket promotion failed: $err </font>");
452: return undef;
453: }
454: Debug("SSL Promotion successful");
455:
456: #
457: # The only thing we'll use the socket for is to send the IDEA key
458: # to the peer:
459:
460: my $Key = lonlocal::CreateCipherKey();
461: print $SSLSocket "$Key\n";
462:
463: lonssl::Close($SSLSocket);
464:
465: Debug("Key exchange complete: $Key");
466:
467: return $Key;
468: }
469: #
470: # InsecureConnection:
471: # If insecure connections are allowd,
472: # exchange a challenge with the client to 'validate' the
473: # client (not really, but that's the protocol):
474: # We produce a challenge string that's sent to the client.
475: # The client must then echo the challenge verbatim to us.
476: #
477: # Parameter:
478: # Socket - Socket open on the client.
479: # Returns:
480: # 1 - success.
481: # 0 - failure (e.g.mismatch or insecure not allowed).
482: #
483: sub InsecureConnection {
484: my $Socket = shift;
485:
486: # Don't even start if insecure connections are not allowed.
1.532 raeburn 487: # return 0 if Insecure connections not allowed.
488: #
489: if (ref($secureconf{'connfrom'}) eq 'HASH') {
490: if ($clientsamedom) {
491: if ($secureconf{'connfrom'}{'dom'} eq 'req') {
492: return 0;
493: }
494: } elsif ($clientsameinst) {
495: if ($secureconf{'connfrom'}{'intdom'} eq 'req') {
496: return 0;
497: }
498: } else {
499: if ($secureconf{'connfrom'}{'other'} eq 'req') {
500: return 0;
501: }
502: }
503: } elsif (!$perlvar{londAllowInsecure}) {
1.200 matthew 504: return 0;
505: }
506:
507: # Fabricate a challenge string and send it..
508:
509: my $challenge = "$$".time; # pid + time.
510: print $Socket "$challenge\n";
511: &status("Waiting for challenge reply");
512:
513: my $answer = <$Socket>;
514: $answer =~s/\W//g;
515: if($challenge eq $answer) {
516: return 1;
1.224 foxr 517: } else {
1.200 matthew 518: logthis("<font color='blue'>WARNING client did not respond to challenge</font>");
519: &status("No challenge reqply");
520: return 0;
521: }
522:
523:
524: }
1.251 foxr 525: #
526: # Safely execute a command (as long as it's not a shel command and doesn
527: # not require/rely on shell escapes. The function operates by doing a
528: # a pipe based fork and capturing stdout and stderr from the pipe.
529: #
530: # Formal Parameters:
531: # $line - A line of text to be executed as a command.
532: # Returns:
533: # The output from that command. If the output is multiline the caller
534: # must know how to split up the output.
535: #
536: #
537: sub execute_command {
538: my ($line) = @_;
539: my @words = split(/\s/, $line); # Bust the command up into words.
540: my $output = "";
541:
542: my $pid = open(CHILD, "-|");
543:
544: if($pid) { # Parent process
545: Debug("In parent process for execute_command");
546: my @data = <CHILD>; # Read the child's outupt...
547: close CHILD;
548: foreach my $output_line (@data) {
549: Debug("Adding $output_line");
550: $output .= $output_line; # Presumably has a \n on it.
551: }
552:
553: } else { # Child process
554: close (STDERR);
555: open (STDERR, ">&STDOUT");# Combine stderr, and stdout...
556: exec(@words); # won't return.
557: }
558: return $output;
559: }
560:
1.200 matthew 561:
1.140 foxr 562: # GetCertificate: Given a transaction that requires a certificate,
563: # this function will extract the certificate from the transaction
564: # request. Note that at this point, the only concept of a certificate
565: # is the hostname to which we are connected.
566: #
567: # Parameter:
568: # request - The request sent by our client (this parameterization may
569: # need to change when we really use a certificate granting
570: # authority.
571: #
572: sub GetCertificate {
573: my $request = shift;
574:
575: return $clientip;
576: }
1.161 foxr 577:
1.178 foxr 578: #
579: # Return true if client is a manager.
580: #
581: sub isManager {
582: return (($ConnectionType eq "manager") || ($ConnectionType eq "both"));
583: }
584: #
585: # Return tru if client can do client functions
586: #
587: sub isClient {
588: return (($ConnectionType eq "client") || ($ConnectionType eq "both"));
589: }
1.161 foxr 590:
591:
1.156 foxr 592: #
593: # ReadManagerTable: Reads in the current manager table. For now this is
594: # done on each manager authentication because:
595: # - These authentications are not frequent
596: # - This allows dynamic changes to the manager table
597: # without the need to signal to the lond.
598: #
599: sub ReadManagerTable {
600:
1.412 foxr 601: &Debug("Reading manager table");
1.156 foxr 602: # Clean out the old table first..
603:
1.166 foxr 604: foreach my $key (keys %managers) {
605: delete $managers{$key};
606: }
607:
608: my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
609: if (!open (MANAGERS, $tablename)) {
1.473 raeburn 610: my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
611: if (&Apache::lonnet::is_LC_dns($hostname)) {
1.472 raeburn 612: &logthis('<font color="red">No manager table. Nobody can manage!!</font>');
613: }
614: return;
1.166 foxr 615: }
616: while(my $host = <MANAGERS>) {
617: chomp($host);
618: if ($host =~ "^#") { # Comment line.
619: next;
620: }
1.368 albertel 621: if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member
1.161 foxr 622: # The entry is of the form:
623: # cluname:hostname
624: # cluname - A 'cluster hostname' is needed in order to negotiate
625: # the host key.
626: # hostname- The dns name of the host.
627: #
1.166 foxr 628: my($cluname, $dnsname) = split(/:/, $host);
629:
630: my $ip = gethostbyname($dnsname);
631: if(defined($ip)) { # bad names don't deserve entry.
632: my $hostip = inet_ntoa($ip);
633: $managers{$hostip} = $cluname;
634: logthis('<font color="green"> registering manager '.
635: "$dnsname as $cluname with $hostip </font>\n");
636: }
637: } else {
638: logthis('<font color="green"> existing host'." $host</font>\n");
1.472 raeburn 639: $managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if cluster memeber
1.166 foxr 640: }
641: }
1.156 foxr 642: }
1.140 foxr 643:
644: #
645: # ValidManager: Determines if a given certificate represents a valid manager.
646: # in this primitive implementation, the 'certificate' is
647: # just the connecting loncapa client name. This is checked
648: # against a valid client list in the configuration.
649: #
650: #
651: sub ValidManager {
652: my $certificate = shift;
653:
1.163 foxr 654: return isManager;
1.140 foxr 655: }
656: #
1.143 foxr 657: # CopyFile: Called as part of the process of installing a
658: # new configuration file. This function copies an existing
659: # file to a backup file.
660: # Parameters:
661: # oldfile - Name of the file to backup.
662: # newfile - Name of the backup file.
663: # Return:
664: # 0 - Failure (errno has failure reason).
665: # 1 - Success.
666: #
667: sub CopyFile {
1.192 foxr 668:
669: my ($oldfile, $newfile) = @_;
1.143 foxr 670:
1.281 matthew 671: if (! copy($oldfile,$newfile)) {
672: return 0;
1.143 foxr 673: }
1.281 matthew 674: chmod(0660, $newfile);
675: return 1;
1.143 foxr 676: }
1.157 foxr 677: #
678: # Host files are passed out with externally visible host IPs.
679: # If, for example, we are behind a fire-wall or NAT host, our
680: # internally visible IP may be different than the externally
681: # visible IP. Therefore, we always adjust the contents of the
682: # host file so that the entry for ME is the IP that we believe
683: # we have. At present, this is defined as the entry that
684: # DNS has for us. If by some chance we are not able to get a
685: # DNS translation for us, then we assume that the host.tab file
686: # is correct.
687: # BUGBUGBUG - in the future, we really should see if we can
688: # easily query the interface(s) instead.
689: # Parameter(s):
690: # contents - The contents of the host.tab to check.
691: # Returns:
692: # newcontents - The adjusted contents.
693: #
694: #
695: sub AdjustHostContents {
696: my $contents = shift;
697: my $adjusted;
698: my $me = $perlvar{'lonHostID'};
699:
1.354 albertel 700: foreach my $line (split(/\n/,$contents)) {
1.472 raeburn 701: if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) ||
702: ($line =~ /^\s*\^/))) {
1.157 foxr 703: chomp($line);
704: my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
705: if ($id eq $me) {
1.354 albertel 706: my $ip = gethostbyname($name);
707: my $ipnew = inet_ntoa($ip);
708: $ip = $ipnew;
1.157 foxr 709: # Reconstruct the host line and append to adjusted:
710:
1.354 albertel 711: my $newline = "$id:$domain:$role:$name:$ip";
712: if($maxcon ne "") { # Not all hosts have loncnew tuning params
713: $newline .= ":$maxcon:$idleto:$mincon";
714: }
715: $adjusted .= $newline."\n";
1.157 foxr 716:
1.354 albertel 717: } else { # Not me, pass unmodified.
718: $adjusted .= $line."\n";
719: }
1.157 foxr 720: } else { # Blank or comment never re-written.
721: $adjusted .= $line."\n"; # Pass blanks and comments as is.
722: }
1.354 albertel 723: }
724: return $adjusted;
1.157 foxr 725: }
1.143 foxr 726: #
727: # InstallFile: Called to install an administrative file:
1.412 foxr 728: # - The file is created int a temp directory called <name>.tmp
729: # - lcinstall file is called to install the file.
730: # since the web app has no direct write access to the table directory
1.143 foxr 731: #
732: # Parameters:
733: # Name of the file
734: # File Contents.
735: # Return:
736: # nonzero - success.
737: # 0 - failure and $! has an errno.
1.412 foxr 738: # Assumptions:
739: # File installtion is a relatively infrequent
1.143 foxr 740: #
741: sub InstallFile {
1.192 foxr 742:
743: my ($Filename, $Contents) = @_;
1.412 foxr 744: # my $TempFile = $Filename.".tmp";
745: my $exedir = $perlvar{'lonDaemons'};
746: my $tmpdir = $exedir.'/tmp/';
747: my $TempFile = $tmpdir."TempTableFile.tmp";
1.143 foxr 748:
749: # Open the file for write:
750:
751: my $fh = IO::File->new("> $TempFile"); # Write to temp.
752: if(!(defined $fh)) {
753: &logthis('<font color="red"> Unable to create '.$TempFile."</font>");
754: return 0;
755: }
756: # write the contents of the file:
757:
758: print $fh ($Contents);
759: $fh->close; # In case we ever have a filesystem w. locking
760:
1.412 foxr 761: chmod(0664, $TempFile); # Everyone can write it.
762:
763: # Use lcinstall file to put the file in the table directory...
764:
765: &Debug("Opening pipe to $exedir/lcinstallfile $TempFile $Filename");
766: my $pf = IO::File->new("| $exedir/lcinstallfile $TempFile $Filename > $exedir/logs/lcinstallfile.log");
767: close $pf;
768: my $err = $?;
769: &Debug("Status is $err");
770: if ($err != 0) {
771: my $msg = $err;
772: if ($err < @installerrors) {
773: $msg = $installerrors[$err];
774: }
775: &logthis("Install failed for table file $Filename : $msg");
776: return 0;
777: }
778:
779: # Remove the temp file:
1.143 foxr 780:
1.412 foxr 781: unlink($TempFile);
1.143 foxr 782:
783: return 1;
784: }
1.200 matthew 785:
786:
1.169 foxr 787: #
788: # ConfigFileFromSelector: converts a configuration file selector
1.411 foxr 789: # into a configuration file pathname.
1.472 raeburn 790: # Supports the following file selectors:
791: # hosts, domain, dns_hosts, dns_domain
1.411 foxr 792: #
1.169 foxr 793: #
794: # Parameters:
795: # selector - Configuration file selector.
796: # Returns:
797: # Full path to the file or undef if the selector is invalid.
798: #
799: sub ConfigFileFromSelector {
800: my $selector = shift;
801: my $tablefile;
802:
1.549 raeburn 803: if ($selector eq 'loncapaCAcrl') {
804: my $tabledir = $perlvar{'lonCertificateDirectory'};
805: if (-d $tabledir) {
806: $tablefile = $tabledir.'/'.$selector.'.pem';
807: }
808: } else {
809: my $tabledir = $perlvar{'lonTabDir'}.'/';
810: if (($selector eq "hosts") || ($selector eq "domain") ||
811: ($selector eq "dns_hosts") || ($selector eq "dns_domain")) {
812: $tablefile = $tabledir.$selector.'.tab';
813: }
1.169 foxr 814: }
815: return $tablefile;
816: }
1.143 foxr 817: #
1.141 foxr 818: # PushFile: Called to do an administrative push of a file.
819: # - Ensure the file being pushed is one we support.
820: # - Backup the old file to <filename.saved>
821: # - Separate the contents of the new file out from the
822: # rest of the request.
823: # - Write the new file.
824: # Parameter:
825: # Request - The entire user request. This consists of a : separated
826: # string pushfile:tablename:contents.
827: # NOTE: The contents may have :'s in it as well making things a bit
828: # more interesting... but not much.
829: # Returns:
830: # String to send to client ("ok" or "refused" if bad file).
831: #
832: sub PushFile {
1.510 raeburn 833: my $request = shift;
1.141 foxr 834: my ($command, $filename, $contents) = split(":", $request, 3);
1.412 foxr 835: &Debug("PushFile");
1.141 foxr 836:
1.549 raeburn 837: # At this point in time, pushes for only the following tables and
838: # CRL file are supported:
1.141 foxr 839: # hosts.tab ($filename eq host).
840: # domain.tab ($filename eq domain).
1.472 raeburn 841: # dns_hosts.tab ($filename eq dns_host).
1.554 raeburn 842: # dns_domain.tab ($filename eq dns_domain).
843: # loncapaCAcrl.pem ($filename eq loncapaCAcrl).
1.141 foxr 844: # Construct the destination filename or reject the request.
845: #
846: # lonManage is supposed to ensure this, however this session could be
847: # part of some elaborate spoof that managed somehow to authenticate.
848: #
849:
1.169 foxr 850:
851: my $tablefile = ConfigFileFromSelector($filename);
852: if(! (defined $tablefile)) {
1.141 foxr 853: return "refused";
854: }
1.412 foxr 855:
1.157 foxr 856: # If the file being pushed is the host file, we adjust the entry for ourself so that the
857: # IP will be our current IP as looked up in dns. Note this is only 99% good as it's possible
858: # to conceive of conditions where we don't have a DNS entry locally. This is possible in a
859: # network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now)
860: # that possibilty.
861:
862: if($filename eq "host") {
863: $contents = AdjustHostContents($contents);
1.549 raeburn 864: } elsif (($filename eq 'dns_host') || ($filename eq 'dns_domain') ||
865: ($filename eq 'loncapaCAcrl')) {
1.510 raeburn 866: if ($contents eq '') {
867: &logthis('<font color="red"> Pushfile: unable to install '
868: .$tablefile." - no data received from push. </font>");
869: return 'error: push had no data';
870: }
871: if (&Apache::lonnet::get_host_ip($clientname)) {
872: my $clienthost = &Apache::lonnet::hostname($clientname);
873: if ($managers{$clientip} eq $clientname) {
874: my $clientprotocol = $Apache::lonnet::protocol{$clientname};
875: $clientprotocol = 'http' if ($clientprotocol ne 'https');
1.549 raeburn 876: my $url;
877: if ($filename eq 'loncapaCAcrl') {
878: $url = '/adm/dns/loncapaCRL';
879: } else {
880: $url = '/adm/'.$filename;
881: $url =~ s{_}{/};
882: }
1.510 raeburn 883: my $request=new HTTP::Request('GET',"$clientprotocol://$clienthost$url");
1.523 raeburn 884: my $response = LONCAPA::LWPReq::makerequest($clientname,$request,'',\%perlvar,60,0);
1.510 raeburn 885: if ($response->is_error()) {
886: &logthis('<font color="red"> Pushfile: unable to install '
887: .$tablefile." - error attempting to pull data. </font>");
888: return 'error: pull failed';
889: } else {
890: my $result = $response->content;
891: chomp($result);
892: unless ($result eq $contents) {
893: &logthis('<font color="red"> Pushfile: unable to install '
894: .$tablefile." - pushed data and pulled data differ. </font>");
895: my $pushleng = length($contents);
896: my $pullleng = length($result);
897: if ($pushleng != $pullleng) {
898: return "error: $pushleng vs $pullleng bytes";
899: } else {
900: return "error: mismatch push and pull";
901: }
902: }
903: }
904: }
905: }
1.157 foxr 906: }
907:
1.141 foxr 908: # Install the new file:
909:
1.412 foxr 910: &logthis("Installing new $tablefile contents:\n$contents");
1.143 foxr 911: if(!InstallFile($tablefile, $contents)) {
912: &logthis('<font color="red"> Pushfile: unable to install '
1.145 foxr 913: .$tablefile." $! </font>");
1.143 foxr 914: return "error:$!";
1.224 foxr 915: } else {
1.143 foxr 916: &logthis('<font color="green"> Installed new '.$tablefile
1.473 raeburn 917: ." - transaction by: $clientname ($clientip)</font>");
1.472 raeburn 918: my $adminmail = $perlvar{'lonAdmEMail'};
919: my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
920: if ($admindom ne '') {
921: my %domconfig =
922: &Apache::lonnet::get_dom('configuration',['contacts'],$admindom);
923: if (ref($domconfig{'contacts'}) eq 'HASH') {
924: if ($domconfig{'contacts'}{'adminemail'} ne '') {
925: $adminmail = $domconfig{'contacts'}{'adminemail'};
926: }
927: }
928: }
929: if ($adminmail =~ /^[^\@]+\@[^\@]+$/) {
930: my $msg = new Mail::Send;
931: $msg->to($adminmail);
932: $msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
933: $msg->add('Content-type','text/plain; charset=UTF-8');
934: if (my $fh = $msg->open()) {
935: print $fh 'Update to '.$tablefile.' from Cluster Manager '.
1.473 raeburn 936: "$clientname ($clientip)\n";
1.472 raeburn 937: $fh->close;
938: }
939: }
1.143 foxr 940: }
941:
1.141 foxr 942: # Indicate success:
943:
944: return "ok";
945:
946: }
1.145 foxr 947:
948: #
949: # Called to re-init either lonc or lond.
950: #
951: # Parameters:
952: # request - The full request by the client. This is of the form
953: # reinit:<process>
954: # where <process> is allowed to be either of
955: # lonc or lond
956: #
957: # Returns:
958: # The string to be sent back to the client either:
959: # ok - Everything worked just fine.
960: # error:why - There was a failure and why describes the reason.
961: #
962: #
963: sub ReinitProcess {
964: my $request = shift;
965:
1.146 foxr 966:
967: # separate the request (reinit) from the process identifier and
968: # validate it producing the name of the .pid file for the process.
969: #
970: #
971: my ($junk, $process) = split(":", $request);
1.147 foxr 972: my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
1.146 foxr 973: if($process eq 'lonc') {
974: $processpidfile = $processpidfile."lonc.pid";
1.147 foxr 975: if (!open(PIDFILE, "< $processpidfile")) {
976: return "error:Open failed for $processpidfile";
977: }
978: my $loncpid = <PIDFILE>;
979: close(PIDFILE);
980: logthis('<font color="red"> Reinitializing lonc pid='.$loncpid
981: ."</font>");
982: kill("USR2", $loncpid);
1.146 foxr 983: } elsif ($process eq 'lond') {
1.147 foxr 984: logthis('<font color="red"> Reinitializing self (lond) </font>');
985: &UpdateHosts; # Lond is us!!
1.146 foxr 986: } else {
987: &logthis('<font color="yellow" Invalid reinit request for '.$process
988: ."</font>");
989: return "error:Invalid process identifier $process";
990: }
1.145 foxr 991: return 'ok';
992: }
1.168 foxr 993: # Validate a line in a configuration file edit script:
994: # Validation includes:
995: # - Ensuring the command is valid.
996: # - Ensuring the command has sufficient parameters
997: # Parameters:
998: # scriptline - A line to validate (\n has been stripped for what it's worth).
1.167 foxr 999: #
1.168 foxr 1000: # Return:
1001: # 0 - Invalid scriptline.
1002: # 1 - Valid scriptline
1003: # NOTE:
1004: # Only the command syntax is checked, not the executability of the
1005: # command.
1006: #
1007: sub isValidEditCommand {
1008: my $scriptline = shift;
1009:
1010: # Line elements are pipe separated:
1011:
1012: my ($command, $key, $newline) = split(/\|/, $scriptline);
1013: &logthis('<font color="green"> isValideditCommand checking: '.
1014: "Command = '$command', Key = '$key', Newline = '$newline' </font>\n");
1015:
1016: if ($command eq "delete") {
1017: #
1018: # key with no newline.
1019: #
1020: if( ($key eq "") || ($newline ne "")) {
1021: return 0; # Must have key but no newline.
1022: } else {
1023: return 1; # Valid syntax.
1024: }
1.169 foxr 1025: } elsif ($command eq "replace") {
1.168 foxr 1026: #
1027: # key and newline:
1028: #
1029: if (($key eq "") || ($newline eq "")) {
1030: return 0;
1031: } else {
1032: return 1;
1033: }
1.169 foxr 1034: } elsif ($command eq "append") {
1035: if (($key ne "") && ($newline eq "")) {
1036: return 1;
1037: } else {
1038: return 0;
1039: }
1.168 foxr 1040: } else {
1041: return 0; # Invalid command.
1042: }
1043: return 0; # Should not get here!!!
1044: }
1.169 foxr 1045: #
1046: # ApplyEdit - Applies an edit command to a line in a configuration
1047: # file. It is the caller's responsiblity to validate the
1048: # edit line.
1049: # Parameters:
1050: # $directive - A single edit directive to apply.
1051: # Edit directives are of the form:
1052: # append|newline - Appends a new line to the file.
1053: # replace|key|newline - Replaces the line with key value 'key'
1054: # delete|key - Deletes the line with key value 'key'.
1055: # $editor - A config file editor object that contains the
1056: # file being edited.
1057: #
1058: sub ApplyEdit {
1.192 foxr 1059:
1060: my ($directive, $editor) = @_;
1.169 foxr 1061:
1062: # Break the directive down into its command and its parameters
1063: # (at most two at this point. The meaning of the parameters, if in fact
1064: # they exist depends on the command).
1065:
1066: my ($command, $p1, $p2) = split(/\|/, $directive);
1067:
1068: if($command eq "append") {
1069: $editor->Append($p1); # p1 - key p2 null.
1070: } elsif ($command eq "replace") {
1071: $editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline.
1072: } elsif ($command eq "delete") {
1073: $editor->DeleteLine($p1); # p1 - key p2 null.
1074: } else { # Should not get here!!!
1075: die "Invalid command given to ApplyEdit $command"
1076: }
1077: }
1078: #
1079: # AdjustOurHost:
1080: # Adjusts a host file stored in a configuration file editor object
1081: # for the true IP address of this host. This is necessary for hosts
1082: # that live behind a firewall.
1083: # Those hosts have a publicly distributed IP of the firewall, but
1084: # internally must use their actual IP. We assume that a given
1085: # host only has a single IP interface for now.
1086: # Formal Parameters:
1087: # editor - The configuration file editor to adjust. This
1088: # editor is assumed to contain a hosts.tab file.
1089: # Strategy:
1090: # - Figure out our hostname.
1091: # - Lookup the entry for this host.
1092: # - Modify the line to contain our IP
1093: # - Do a replace for this host.
1094: sub AdjustOurHost {
1095: my $editor = shift;
1096:
1097: # figure out who I am.
1098:
1099: my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname.
1100:
1101: # Get my host file entry.
1102:
1103: my $ConfigLine = $editor->Find($myHostName);
1104: if(! (defined $ConfigLine)) {
1105: die "AdjustOurHost - no entry for me in hosts file $myHostName";
1106: }
1107: # figure out my IP:
1108: # Use the config line to get my hostname.
1109: # Use gethostbyname to translate that into an IP address.
1110: #
1.338 albertel 1111: my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
1.169 foxr 1112: #
1113: # Reassemble the config line from the elements in the list.
1114: # Note that if the loncnew items were not present before, they will
1115: # be now even if they would be empty
1116: #
1117: my $newConfigLine = $id;
1.338 albertel 1118: foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) {
1.169 foxr 1119: $newConfigLine .= ":".$item;
1120: }
1121: # Replace the line:
1122:
1123: $editor->ReplaceLine($id, $newConfigLine);
1124:
1125: }
1126: #
1127: # ReplaceConfigFile:
1128: # Replaces a configuration file with the contents of a
1129: # configuration file editor object.
1130: # This is done by:
1131: # - Copying the target file to <filename>.old
1132: # - Writing the new file to <filename>.tmp
1133: # - Moving <filename.tmp> -> <filename>
1134: # This laborious process ensures that the system is never without
1135: # a configuration file that's at least valid (even if the contents
1136: # may be dated).
1137: # Parameters:
1138: # filename - Name of the file to modify... this is a full path.
1139: # editor - Editor containing the file.
1140: #
1141: sub ReplaceConfigFile {
1.192 foxr 1142:
1143: my ($filename, $editor) = @_;
1.168 foxr 1144:
1.169 foxr 1145: CopyFile ($filename, $filename.".old");
1146:
1147: my $contents = $editor->Get(); # Get the contents of the file.
1148:
1149: InstallFile($filename, $contents);
1150: }
1.168 foxr 1151: #
1152: #
1153: # Called to edit a configuration table file
1.167 foxr 1154: # Parameters:
1155: # request - The entire command/request sent by lonc or lonManage
1156: # Return:
1157: # The reply to send to the client.
1.168 foxr 1158: #
1.167 foxr 1159: sub EditFile {
1160: my $request = shift;
1161:
1162: # Split the command into it's pieces: edit:filetype:script
1163:
1.339 albertel 1164: my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script
1.167 foxr 1165:
1166: # Check the pre-coditions for success:
1167:
1.339 albertel 1168: if($cmd != "edit") { # Something is amiss afoot alack.
1.167 foxr 1169: return "error:edit request detected, but request != 'edit'\n";
1170: }
1171: if( ($filetype ne "hosts") &&
1172: ($filetype ne "domain")) {
1173: return "error:edit requested with invalid file specifier: $filetype \n";
1174: }
1175:
1176: # Split the edit script and check it's validity.
1.168 foxr 1177:
1178: my @scriptlines = split(/\n/, $script); # one line per element.
1179: my $linecount = scalar(@scriptlines);
1180: for(my $i = 0; $i < $linecount; $i++) {
1181: chomp($scriptlines[$i]);
1182: if(!isValidEditCommand($scriptlines[$i])) {
1183: return "error:edit with bad script line: '$scriptlines[$i]' \n";
1184: }
1185: }
1.145 foxr 1186:
1.167 foxr 1187: # Execute the edit operation.
1.169 foxr 1188: # - Create a config file editor for the appropriate file and
1189: # - execute each command in the script:
1190: #
1191: my $configfile = ConfigFileFromSelector($filetype);
1192: if (!(defined $configfile)) {
1193: return "refused\n";
1194: }
1195: my $editor = ConfigFileEdit->new($configfile);
1.167 foxr 1196:
1.169 foxr 1197: for (my $i = 0; $i < $linecount; $i++) {
1198: ApplyEdit($scriptlines[$i], $editor);
1199: }
1200: # If the file is the host file, ensure that our host is
1201: # adjusted to have our ip:
1202: #
1203: if($filetype eq "host") {
1204: AdjustOurHost($editor);
1205: }
1206: # Finally replace the current file with our file.
1207: #
1208: ReplaceConfigFile($configfile, $editor);
1.167 foxr 1209:
1210: return "ok\n";
1211: }
1.207 foxr 1212:
1.255 foxr 1213: # read_profile
1214: #
1215: # Returns a set of specific entries from a user's profile file.
1216: # this is a utility function that is used by both get_profile_entry and
1217: # get_profile_entry_encrypted.
1218: #
1219: # Parameters:
1220: # udom - Domain in which the user exists.
1221: # uname - User's account name (loncapa account)
1222: # namespace - The profile namespace to open.
1223: # what - A set of & separated queries.
1224: # Returns:
1225: # If all ok: - The string that needs to be shipped back to the user.
1226: # If failure - A string that starts with error: followed by the failure
1227: # reason.. note that this probabyl gets shipped back to the
1228: # user as well.
1229: #
1230: sub read_profile {
1231: my ($udom, $uname, $namespace, $what) = @_;
1232:
1233: my $hashref = &tie_user_hash($udom, $uname, $namespace,
1234: &GDBM_READER());
1235: if ($hashref) {
1236: my @queries=split(/\&/,$what);
1.440 raeburn 1237: if ($namespace eq 'roles') {
1238: @queries = map { &unescape($_); } @queries;
1239: }
1.255 foxr 1240: my $qresult='';
1241:
1242: for (my $i=0;$i<=$#queries;$i++) {
1243: $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.
1244: }
1245: $qresult=~s/\&$//; # Remove trailing & from last lookup.
1.311 albertel 1246: if (&untie_user_hash($hashref)) {
1.255 foxr 1247: return $qresult;
1248: } else {
1249: return "error: ".($!+0)." untie (GDBM) Failed";
1250: }
1251: } else {
1252: if ($!+0 == 2) {
1253: return "error:No such file or GDBM reported bad block error";
1254: } else {
1255: return "error: ".($!+0)." tie (GDBM) Failed";
1256: }
1257: }
1258:
1259: }
1.214 foxr 1260: #--------------------- Request Handlers --------------------------------------------
1261: #
1.215 foxr 1262: # By convention each request handler registers itself prior to the sub
1263: # declaration:
1.214 foxr 1264: #
1265:
1.216 foxr 1266: #++
1267: #
1.214 foxr 1268: # Handles ping requests.
1269: # Parameters:
1270: # $cmd - the actual keyword that invoked us.
1271: # $tail - the tail of the request that invoked us.
1272: # $replyfd- File descriptor connected to the client
1273: # Implicit Inputs:
1274: # $currenthostid - Global variable that carries the name of the host we are
1275: # known as.
1276: # Returns:
1277: # 1 - Ok to continue processing.
1278: # 0 - Program should exit.
1279: # Side effects:
1280: # Reply information is sent to the client.
1281: sub ping_handler {
1282: my ($cmd, $tail, $client) = @_;
1283: Debug("$cmd $tail $client .. $currenthostid:");
1284:
1.387 albertel 1285: Reply( $client,\$currenthostid,"$cmd:$tail");
1.214 foxr 1286:
1287: return 1;
1288: }
1289: ®ister_handler("ping", \&ping_handler, 0, 1, 1); # Ping unencoded, client or manager.
1290:
1.216 foxr 1291: #++
1.215 foxr 1292: #
1293: # Handles pong requests. Pong replies with our current host id, and
1294: # the results of a ping sent to us via our lonc.
1295: #
1296: # Parameters:
1297: # $cmd - the actual keyword that invoked us.
1298: # $tail - the tail of the request that invoked us.
1299: # $replyfd- File descriptor connected to the client
1300: # Implicit Inputs:
1301: # $currenthostid - Global variable that carries the name of the host we are
1302: # connected to.
1303: # Returns:
1304: # 1 - Ok to continue processing.
1305: # 0 - Program should exit.
1306: # Side effects:
1307: # Reply information is sent to the client.
1308: sub pong_handler {
1309: my ($cmd, $tail, $replyfd) = @_;
1310:
1.365 albertel 1311: my $reply=&Apache::lonnet::reply("ping",$clientname);
1.215 foxr 1312: &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");
1313: return 1;
1314: }
1315: ®ister_handler("pong", \&pong_handler, 0, 1, 1); # Pong unencoded, client or manager
1316:
1.216 foxr 1317: #++
1318: # Called to establish an encrypted session key with the remote client.
1319: # Note that with secure lond, in most cases this function is never
1320: # invoked. Instead, the secure session key is established either
1321: # via a local file that's locked down tight and only lives for a short
1322: # time, or via an ssl tunnel...and is generated from a bunch-o-random
1323: # bits from /dev/urandom, rather than the predictable pattern used by
1324: # by this sub. This sub is only used in the old-style insecure
1325: # key negotiation.
1326: # Parameters:
1327: # $cmd - the actual keyword that invoked us.
1328: # $tail - the tail of the request that invoked us.
1329: # $replyfd- File descriptor connected to the client
1330: # Implicit Inputs:
1331: # $currenthostid - Global variable that carries the name of the host
1332: # known as.
1.448 raeburn 1333: # $clientname - Global variable that carries the name of the host we're connected to.
1.216 foxr 1334: # Returns:
1335: # 1 - Ok to continue processing.
1336: # 0 - Program should exit.
1337: # Implicit Outputs:
1338: # Reply information is sent to the client.
1339: # $cipher is set with a reference to a new IDEA encryption object.
1340: #
1341: sub establish_key_handler {
1342: my ($cmd, $tail, $replyfd) = @_;
1343:
1344: my $buildkey=time.$$.int(rand 100000);
1345: $buildkey=~tr/1-6/A-F/;
1346: $buildkey=int(rand 100000).$buildkey.int(rand 100000);
1347: my $key=$currenthostid.$clientname;
1348: $key=~tr/a-z/A-Z/;
1349: $key=~tr/G-P/0-9/;
1350: $key=~tr/Q-Z/0-9/;
1351: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
1352: $key=substr($key,0,32);
1353: my $cipherkey=pack("H32",$key);
1354: $cipher=new IDEA $cipherkey;
1.387 albertel 1355: &Reply($replyfd, \$buildkey, "$cmd:$tail");
1.216 foxr 1356:
1357: return 1;
1358:
1359: }
1360: ®ister_handler("ekey", \&establish_key_handler, 0, 1,1);
1361:
1.217 foxr 1362: # Handler for the load command. Returns the current system load average
1363: # to the requestor.
1364: #
1365: # Parameters:
1366: # $cmd - the actual keyword that invoked us.
1367: # $tail - the tail of the request that invoked us.
1368: # $replyfd- File descriptor connected to the client
1369: # Implicit Inputs:
1370: # $currenthostid - Global variable that carries the name of the host
1371: # known as.
1.448 raeburn 1372: # $clientname - Global variable that carries the name of the host we're connected to.
1.217 foxr 1373: # Returns:
1374: # 1 - Ok to continue processing.
1375: # 0 - Program should exit.
1376: # Side effects:
1377: # Reply information is sent to the client.
1378: sub load_handler {
1379: my ($cmd, $tail, $replyfd) = @_;
1380:
1.463 foxr 1381:
1382:
1.217 foxr 1383: # Get the load average from /proc/loadavg and calculate it as a percentage of
1384: # the allowed load limit as set by the perl global variable lonLoadLim
1385:
1386: my $loadavg;
1387: my $loadfile=IO::File->new('/proc/loadavg');
1388:
1389: $loadavg=<$loadfile>;
1390: $loadavg =~ s/\s.*//g; # Extract the first field only.
1391:
1392: my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
1393:
1.387 albertel 1394: &Reply( $replyfd, \$loadpercent, "$cmd:$tail");
1.217 foxr 1395:
1396: return 1;
1397: }
1.263 albertel 1398: ®ister_handler("load", \&load_handler, 0, 1, 0);
1.217 foxr 1399:
1400: #
1401: # Process the userload request. This sub returns to the client the current
1402: # user load average. It can be invoked either by clients or managers.
1403: #
1404: # Parameters:
1405: # $cmd - the actual keyword that invoked us.
1406: # $tail - the tail of the request that invoked us.
1407: # $replyfd- File descriptor connected to the client
1408: # Implicit Inputs:
1409: # $currenthostid - Global variable that carries the name of the host
1410: # known as.
1.448 raeburn 1411: # $clientname - Global variable that carries the name of the host we're connected to.
1.217 foxr 1412: # Returns:
1413: # 1 - Ok to continue processing.
1414: # 0 - Program should exit
1415: # Implicit inputs:
1416: # whatever the userload() function requires.
1417: # Implicit outputs:
1418: # the reply is written to the client.
1419: #
1420: sub user_load_handler {
1421: my ($cmd, $tail, $replyfd) = @_;
1422:
1.365 albertel 1423: my $userloadpercent=&Apache::lonnet::userload();
1.387 albertel 1424: &Reply($replyfd, \$userloadpercent, "$cmd:$tail");
1.217 foxr 1425:
1426: return 1;
1427: }
1.263 albertel 1428: ®ister_handler("userload", \&user_load_handler, 0, 1, 0);
1.217 foxr 1429:
1.218 foxr 1430: # Process a request for the authorization type of a user:
1431: # (userauth).
1432: #
1433: # Parameters:
1434: # $cmd - the actual keyword that invoked us.
1435: # $tail - the tail of the request that invoked us.
1436: # $replyfd- File descriptor connected to the client
1437: # Returns:
1438: # 1 - Ok to continue processing.
1439: # 0 - Program should exit
1440: # Implicit outputs:
1441: # The user authorization type is written to the client.
1442: #
1443: sub user_authorization_type {
1444: my ($cmd, $tail, $replyfd) = @_;
1445:
1446: my $userinput = "$cmd:$tail";
1447:
1448: # Pull the domain and username out of the command tail.
1.222 foxr 1449: # and call get_auth_type to determine the authentication type.
1.218 foxr 1450:
1451: my ($udom,$uname)=split(/:/,$tail);
1.222 foxr 1452: my $result = &get_auth_type($udom, $uname);
1.218 foxr 1453: if($result eq "nouser") {
1454: &Failure( $replyfd, "unknown_user\n", $userinput);
1455: } else {
1456: #
1.222 foxr 1457: # We only want to pass the second field from get_auth_type
1.218 foxr 1458: # for ^krb.. otherwise we'll be handing out the encrypted
1459: # password for internals e.g.
1460: #
1461: my ($type,$otherinfo) = split(/:/,$result);
1462: if($type =~ /^krb/) {
1463: $type = $result;
1.269 raeburn 1464: } else {
1465: $type .= ':';
1466: }
1.387 albertel 1467: &Reply( $replyfd, \$type, $userinput);
1.218 foxr 1468: }
1469:
1470: return 1;
1471: }
1472: ®ister_handler("currentauth", \&user_authorization_type, 1, 1, 0);
1473:
1474: # Process a request by a manager to push a hosts or domain table
1475: # to us. We pick apart the command and pass it on to the subs
1476: # that already exist to do this.
1477: #
1478: # Parameters:
1479: # $cmd - the actual keyword that invoked us.
1480: # $tail - the tail of the request that invoked us.
1481: # $client - File descriptor connected to the client
1482: # Returns:
1483: # 1 - Ok to continue processing.
1484: # 0 - Program should exit
1485: # Implicit Output:
1486: # a reply is written to the client.
1487: sub push_file_handler {
1488: my ($cmd, $tail, $client) = @_;
1.412 foxr 1489: &Debug("In push file handler");
1.218 foxr 1490: my $userinput = "$cmd:$tail";
1491:
1492: # At this time we only know that the IP of our partner is a valid manager
1493: # the code below is a hook to do further authentication (e.g. to resolve
1494: # spoofing).
1495:
1496: my $cert = &GetCertificate($userinput);
1.412 foxr 1497: if(&ValidManager($cert)) {
1498: &Debug("Valid manager: $client");
1.218 foxr 1499:
1500: # Now presumably we have the bona fides of both the peer host and the
1501: # process making the request.
1502:
1503: my $reply = &PushFile($userinput);
1.387 albertel 1504: &Reply($client, \$reply, $userinput);
1.218 foxr 1505:
1506: } else {
1.412 foxr 1507: &logthis("push_file_handler $client is not valid");
1.218 foxr 1508: &Failure( $client, "refused\n", $userinput);
1509: }
1.219 foxr 1510: return 1;
1.218 foxr 1511: }
1512: ®ister_handler("pushfile", \&push_file_handler, 1, 0, 1);
1513:
1.399 raeburn 1514: # The du_handler routine should be considered obsolete and is retained
1515: # for communication with legacy servers. Please see the du2_handler.
1.243 banghart 1516: #
1.399 raeburn 1517: # du - list the disk usage of a directory recursively.
1.243 banghart 1518: #
1519: # note: stolen code from the ls file handler
1520: # under construction by Rick Banghart
1521: # .
1522: # Parameters:
1523: # $cmd - The command that dispatched us (du).
1524: # $ududir - The directory path to list... I'm not sure what this
1525: # is relative as things like ls:. return e.g.
1526: # no_such_dir.
1527: # $client - Socket open on the client.
1528: # Returns:
1529: # 1 - indicating that the daemon should not disconnect.
1530: # Side Effects:
1531: # The reply is written to $client.
1532: #
1533: sub du_handler {
1534: my ($cmd, $ududir, $client) = @_;
1.339 albertel 1535: ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
1.251 foxr 1536: my $userinput = "$cmd:$ududir";
1537:
1.245 albertel 1538: if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
1539: &Failure($client,"refused\n","$cmd:$ududir");
1540: return 1;
1541: }
1.249 foxr 1542: # Since $ududir could have some nasties in it,
1543: # we will require that ududir is a valid
1544: # directory. Just in case someone tries to
1545: # slip us a line like .;(cd /home/httpd rm -rf*)
1546: # etc.
1547: #
1548: if (-d $ududir) {
1.292 albertel 1549: my $total_size=0;
1550: my $code=sub {
1551: if ($_=~/\.\d+\./) { return;}
1552: if ($_=~/\.meta$/) { return;}
1.362 albertel 1553: if (-d $_) { return;}
1.292 albertel 1554: $total_size+=(stat($_))[7];
1555: };
1.295 raeburn 1556: chdir($ududir);
1.292 albertel 1557: find($code,$ududir);
1558: $total_size=int($total_size/1024);
1.387 albertel 1559: &Reply($client,\$total_size,"$cmd:$ududir");
1.249 foxr 1560: } else {
1.251 foxr 1561: &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");
1.249 foxr 1562: }
1.243 banghart 1563: return 1;
1564: }
1565: ®ister_handler("du", \&du_handler, 0, 1, 0);
1.218 foxr 1566:
1.399 raeburn 1567: # Please also see the du_handler, which is obsoleted by du2.
1568: # du2_handler differs from du_handler in that required path to directory
1569: # provided by &propath() is prepended in the handler instead of on the
1570: # client side.
1.239 foxr 1571: #
1.399 raeburn 1572: # du2 - list the disk usage of a directory recursively.
1573: #
1574: # Parameters:
1575: # $cmd - The command that dispatched us (du).
1576: # $tail - The tail of the request that invoked us.
1577: # $tail is a : separated list of the following:
1578: # - $ududir - directory path to list (before prepending)
1579: # - $getpropath = 1 if &propath() should prepend
1580: # - $uname - username to use for &propath or user dir
1581: # - $udom - domain to use for &propath or user dir
1582: # All are escaped.
1583: # $client - Socket open on the client.
1584: # Returns:
1585: # 1 - indicating that the daemon should not disconnect.
1586: # Side Effects:
1587: # The reply is written to $client.
1588: #
1589:
1590: sub du2_handler {
1591: my ($cmd, $tail, $client) = @_;
1592: my ($ududir,$getpropath,$uname,$udom) = map { &unescape($_) } (split(/:/, $tail));
1593: my $userinput = "$cmd:$tail";
1594: if (($ududir=~/\.\./) || (($ududir!~m|^/home/httpd/|) && (!$getpropath))) {
1595: &Failure($client,"refused\n","$cmd:$tail");
1596: return 1;
1597: }
1598: if ($getpropath) {
1599: if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
1600: $ududir = &propath($udom,$uname).'/'.$ududir;
1601: } else {
1602: &Failure($client,"refused\n","$cmd:$tail");
1603: return 1;
1604: }
1605: }
1606: # Since $ududir could have some nasties in it,
1607: # we will require that ududir is a valid
1608: # directory. Just in case someone tries to
1609: # slip us a line like .;(cd /home/httpd rm -rf*)
1610: # etc.
1611: #
1612: if (-d $ududir) {
1613: my $total_size=0;
1614: my $code=sub {
1615: if ($_=~/\.\d+\./) { return;}
1616: if ($_=~/\.meta$/) { return;}
1617: if (-d $_) { return;}
1618: $total_size+=(stat($_))[7];
1619: };
1620: chdir($ududir);
1621: find($code,$ududir);
1622: $total_size=int($total_size/1024);
1623: &Reply($client,\$total_size,"$cmd:$ududir");
1624: } else {
1625: &Failure($client, "bad_directory:$ududir\n","$cmd:$tail");
1626: }
1627: return 1;
1628: }
1629: ®ister_handler("du2", \&du2_handler, 0, 1, 0);
1630:
1631: #
1632: # The ls_handler routine should be considered obsolete and is retained
1633: # for communication with legacy servers. Please see the ls3_handler.
1.280 matthew 1634: #
1.239 foxr 1635: # ls - list the contents of a directory. For each file in the
1636: # selected directory the filename followed by the full output of
1637: # the stat function is returned. The returned info for each
1638: # file are separated by ':'. The stat fields are separated by &'s.
1.529 raeburn 1639: #
1640: # If the requested path contains /../ or is:
1641: #
1642: # 1. for a directory, and the path does not begin with one of:
1.530 raeburn 1643: # (a) /home/httpd/html/res/<domain>
1.539 raeburn 1644: # (b) /home/httpd/html/userfiles/
1.529 raeburn 1645: # (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
1646: # or is:
1647: #
1.538 raeburn 1648: # 2. for a file, and the path (after prepending) does not begin with one of:
1.539 raeburn 1649: # (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
1650: # (b) /home/httpd/html/res/<domain>/<username>/
1651: # (c) /home/httpd/html/userfiles/<domain>/<username>/
1.529 raeburn 1652: #
1653: # the response will be "refused".
1654: #
1.239 foxr 1655: # Parameters:
1656: # $cmd - The command that dispatched us (ls).
1657: # $ulsdir - The directory path to list... I'm not sure what this
1658: # is relative as things like ls:. return e.g.
1659: # no_such_dir.
1660: # $client - Socket open on the client.
1661: # Returns:
1662: # 1 - indicating that the daemon should not disconnect.
1663: # Side Effects:
1664: # The reply is written to $client.
1665: #
1666: sub ls_handler {
1.280 matthew 1667: # obsoleted by ls2_handler
1.239 foxr 1668: my ($cmd, $ulsdir, $client) = @_;
1669:
1670: my $userinput = "$cmd:$ulsdir";
1671:
1672: my $obs;
1673: my $rights;
1674: my $ulsout='';
1675: my $ulsfn;
1.529 raeburn 1676: if ($ulsdir =~m{/\.\./}) {
1677: &Failure($client,"refused\n",$userinput);
1678: return 1;
1679: }
1.239 foxr 1680: if (-e $ulsdir) {
1681: if(-d $ulsdir) {
1.539 raeburn 1682: unless (($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||
1683: ($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles})) {
1.529 raeburn 1684: &Failure($client,"refused\n",$userinput);
1685: return 1;
1686: }
1.239 foxr 1687: if (opendir(LSDIR,$ulsdir)) {
1688: while ($ulsfn=readdir(LSDIR)) {
1.291 albertel 1689: undef($obs);
1690: undef($rights);
1.239 foxr 1691: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1692: #We do some obsolete checking here
1693: if(-e $ulsdir.'/'.$ulsfn.".meta") {
1694: open(FILE, $ulsdir.'/'.$ulsfn.".meta");
1695: my @obsolete=<FILE>;
1696: foreach my $obsolete (@obsolete) {
1.301 www 1697: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
1.239 foxr 1698: if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
1699: }
1700: }
1701: $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
1702: if($obs eq '1') { $ulsout.="&1"; }
1703: else { $ulsout.="&0"; }
1704: if($rights eq '1') { $ulsout.="&1:"; }
1705: else { $ulsout.="&0:"; }
1706: }
1707: closedir(LSDIR);
1708: }
1709: } else {
1.539 raeburn 1710: unless (($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) ||
1711: ($ulsdir =~ m{^/home/httpd/html/(?:res|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/})) {
1.529 raeburn 1712: &Failure($client,"refused\n",$userinput);
1713: return 1;
1714: }
1.239 foxr 1715: my @ulsstats=stat($ulsdir);
1716: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1717: }
1718: } else {
1719: $ulsout='no_such_dir';
1720: }
1721: if ($ulsout eq '') { $ulsout='empty'; }
1.387 albertel 1722: &Reply($client, \$ulsout, $userinput); # This supports debug logging.
1.239 foxr 1723:
1724: return 1;
1725:
1726: }
1727: ®ister_handler("ls", \&ls_handler, 0, 1, 0);
1728:
1.399 raeburn 1729: # The ls2_handler routine should be considered obsolete and is retained
1730: # for communication with legacy servers. Please see the ls3_handler.
1731: # Please also see the ls_handler, which was itself obsoleted by ls2.
1.280 matthew 1732: # ls2_handler differs from ls_handler in that it escapes its return
1733: # values before concatenating them together with ':'s.
1734: #
1735: # ls2 - list the contents of a directory. For each file in the
1736: # selected directory the filename followed by the full output of
1737: # the stat function is returned. The returned info for each
1738: # file are separated by ':'. The stat fields are separated by &'s.
1.529 raeburn 1739: #
1740: # If the requested path contains /../ or is:
1741: #
1742: # 1. for a directory, and the path does not begin with one of:
1.530 raeburn 1743: # (a) /home/httpd/html/res/<domain>
1.539 raeburn 1744: # (b) /home/httpd/html/userfiles/
1.529 raeburn 1745: # (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
1746: # or is:
1747: #
1.538 raeburn 1748: # 2. for a file, and the path (after prepending) does not begin with one of:
1.539 raeburn 1749: # (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
1750: # (b) /home/httpd/html/res/<domain>/<username>/
1751: # (c) /home/httpd/html/userfiles/<domain>/<username>/
1.529 raeburn 1752: #
1753: # the response will be "refused".
1754: #
1.280 matthew 1755: # Parameters:
1756: # $cmd - The command that dispatched us (ls).
1757: # $ulsdir - The directory path to list... I'm not sure what this
1758: # is relative as things like ls:. return e.g.
1759: # no_such_dir.
1760: # $client - Socket open on the client.
1761: # Returns:
1762: # 1 - indicating that the daemon should not disconnect.
1763: # Side Effects:
1764: # The reply is written to $client.
1765: #
1766: sub ls2_handler {
1767: my ($cmd, $ulsdir, $client) = @_;
1768:
1769: my $userinput = "$cmd:$ulsdir";
1770:
1771: my $obs;
1772: my $rights;
1773: my $ulsout='';
1774: my $ulsfn;
1.529 raeburn 1775: if ($ulsdir =~m{/\.\./}) {
1776: &Failure($client,"refused\n",$userinput);
1777: return 1;
1778: }
1.280 matthew 1779: if (-e $ulsdir) {
1780: if(-d $ulsdir) {
1.539 raeburn 1781: unless (($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||
1782: ($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles})) {
1.529 raeburn 1783: &Failure($client,"refused\n","$userinput");
1784: return 1;
1785: }
1.280 matthew 1786: if (opendir(LSDIR,$ulsdir)) {
1787: while ($ulsfn=readdir(LSDIR)) {
1.291 albertel 1788: undef($obs);
1789: undef($rights);
1.280 matthew 1790: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1791: #We do some obsolete checking here
1792: if(-e $ulsdir.'/'.$ulsfn.".meta") {
1793: open(FILE, $ulsdir.'/'.$ulsfn.".meta");
1794: my @obsolete=<FILE>;
1795: foreach my $obsolete (@obsolete) {
1.301 www 1796: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
1.280 matthew 1797: if($obsolete =~ m|(<copyright>)(default)|) {
1798: $rights = 1;
1799: }
1800: }
1801: }
1802: my $tmp = $ulsfn.'&'.join('&',@ulsstats);
1803: if ($obs eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
1804: if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
1805: $ulsout.= &escape($tmp).':';
1806: }
1807: closedir(LSDIR);
1808: }
1809: } else {
1.539 raeburn 1810: unless (($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) ||
1811: ($ulsdir =~ m{^/home/httpd/html/(?:res|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/})) {
1.529 raeburn 1812: &Failure($client,"refused\n",$userinput);
1813: return 1;
1814: }
1.280 matthew 1815: my @ulsstats=stat($ulsdir);
1816: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1817: }
1818: } else {
1819: $ulsout='no_such_dir';
1820: }
1821: if ($ulsout eq '') { $ulsout='empty'; }
1.387 albertel 1822: &Reply($client, \$ulsout, $userinput); # This supports debug logging.
1.280 matthew 1823: return 1;
1824: }
1825: ®ister_handler("ls2", \&ls2_handler, 0, 1, 0);
1.399 raeburn 1826: #
1827: # ls3 - list the contents of a directory. For each file in the
1828: # selected directory the filename followed by the full output of
1829: # the stat function is returned. The returned info for each
1830: # file are separated by ':'. The stat fields are separated by &'s.
1.529 raeburn 1831: #
1832: # If the requested path (after prepending) contains /../ or is:
1833: #
1834: # 1. for a directory, and the path does not begin with one of:
1.530 raeburn 1835: # (a) /home/httpd/html/res/<domain>
1.539 raeburn 1836: # (b) /home/httpd/html/userfiles/
1.529 raeburn 1837: # (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
1.539 raeburn 1838: # (d) /home/httpd/html/priv/<domain> and client is the homeserver
1.529 raeburn 1839: #
1.530 raeburn 1840: # or is:
1.529 raeburn 1841: #
1.538 raeburn 1842: # 2. for a file, and the path (after prepending) does not begin with one of:
1.539 raeburn 1843: # (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
1844: # (b) /home/httpd/html/res/<domain>/<username>/
1845: # (c) /home/httpd/html/userfiles/<domain>/<username>/
1846: # (d) /home/httpd/html/priv/<domain>/<username>/ and client is the homeserver
1.529 raeburn 1847: #
1848: # the response will be "refused".
1849: #
1.399 raeburn 1850: # Parameters:
1851: # $cmd - The command that dispatched us (ls).
1852: # $tail - The tail of the request that invoked us.
1853: # $tail is a : separated list of the following:
1854: # - $ulsdir - directory path to list (before prepending)
1855: # - $getpropath = 1 if &propath() should prepend
1856: # - $getuserdir = 1 if path to user dir in lonUsers should
1857: # prepend
1858: # - $alternate_root - path to prepend
1859: # - $uname - username to use for &propath or user dir
1860: # - $udom - domain to use for &propath or user dir
1861: # All of these except $getpropath and &getuserdir are escaped.
1862: # no_such_dir.
1863: # $client - Socket open on the client.
1864: # Returns:
1865: # 1 - indicating that the daemon should not disconnect.
1866: # Side Effects:
1867: # The reply is written to $client.
1868: #
1869:
1870: sub ls3_handler {
1871: my ($cmd, $tail, $client) = @_;
1872: my $userinput = "$cmd:$tail";
1873: my ($ulsdir,$getpropath,$getuserdir,$alternate_root,$uname,$udom) =
1874: split(/:/,$tail);
1875: if (defined($ulsdir)) {
1876: $ulsdir = &unescape($ulsdir);
1877: }
1878: if (defined($alternate_root)) {
1879: $alternate_root = &unescape($alternate_root);
1880: }
1881: if (defined($uname)) {
1882: $uname = &unescape($uname);
1883: }
1884: if (defined($udom)) {
1885: $udom = &unescape($udom);
1886: }
1887:
1888: my $dir_root = $perlvar{'lonDocRoot'};
1.529 raeburn 1889: if (($getpropath) || ($getuserdir)) {
1.399 raeburn 1890: if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
1891: $dir_root = &propath($udom,$uname);
1892: $dir_root =~ s/\/$//;
1893: } else {
1.529 raeburn 1894: &Failure($client,"refused\n",$userinput);
1.399 raeburn 1895: return 1;
1896: }
1.400 raeburn 1897: } elsif ($alternate_root ne '') {
1.399 raeburn 1898: $dir_root = $alternate_root;
1899: }
1.408 raeburn 1900: if (($dir_root ne '') && ($dir_root ne '/')) {
1.400 raeburn 1901: if ($ulsdir =~ /^\//) {
1902: $ulsdir = $dir_root.$ulsdir;
1903: } else {
1904: $ulsdir = $dir_root.'/'.$ulsdir;
1905: }
1.399 raeburn 1906: }
1.529 raeburn 1907: if ($ulsdir =~m{/\.\./}) {
1908: &Failure($client,"refused\n",$userinput);
1909: return 1;
1910: }
1911: my $islocal;
1912: my @machine_ids = &Apache::lonnet::current_machine_ids();
1913: if (grep(/^\Q$clientname\E$/,@machine_ids)) {
1914: $islocal = 1;
1915: }
1.399 raeburn 1916: my $obs;
1917: my $rights;
1918: my $ulsout='';
1919: my $ulsfn;
1.547 raeburn 1920:
1921: my ($crscheck,$toplevel,$currdom,$currnum,$skip);
1922: unless ($islocal) {
1923: my ($major,$minor) = split(/\./,$clientversion);
1924: if (($major < 2) || ($major == 2 && $minor < 12)) {
1925: $crscheck = 1;
1926: }
1927: }
1.399 raeburn 1928: if (-e $ulsdir) {
1929: if(-d $ulsdir) {
1.529 raeburn 1930: unless (($getpropath) || ($getuserdir) ||
1.539 raeburn 1931: ($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain|userfiles/)}) ||
1932: ($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles}) ||
1933: (($ulsdir =~ m{^/home/httpd/html/priv/$LONCAPA::match_domain}) && ($islocal))) {
1.529 raeburn 1934: &Failure($client,"refused\n",$userinput);
1935: return 1;
1936: }
1.547 raeburn 1937: if (($crscheck) &&
1938: ($ulsdir =~ m{^/home/httpd/html/res/($LONCAPA::match_domain)(/?$|/$LONCAPA::match_courseid)})) {
1939: ($currdom,my $posscnum) = ($1,$2);
1940: if (($posscnum eq '') || ($posscnum eq '/')) {
1941: $toplevel = 1;
1942: } else {
1943: $posscnum =~ s{^/+}{};
1944: if (&LONCAPA::Lond::is_course($currdom,$posscnum)) {
1945: $skip = 1;
1946: }
1947: }
1948: }
1949: if ((!$skip) && (opendir(LSDIR,$ulsdir))) {
1.399 raeburn 1950: while ($ulsfn=readdir(LSDIR)) {
1.547 raeburn 1951: if (($crscheck) && ($toplevel) && ($currdom ne '') &&
1952: ($ulsfn =~ /^$LONCAPA::match_courseid$/) && (-d "$ulsdir/$ulsfn")) {
1953: if (&LONCAPA::Lond::is_course($currdom,$ulsfn)) {
1954: next;
1955: }
1956: }
1.399 raeburn 1957: undef($obs);
1958: undef($rights);
1959: my @ulsstats=stat($ulsdir.'/'.$ulsfn);
1960: #We do some obsolete checking here
1961: if(-e $ulsdir.'/'.$ulsfn.".meta") {
1962: open(FILE, $ulsdir.'/'.$ulsfn.".meta");
1963: my @obsolete=<FILE>;
1964: foreach my $obsolete (@obsolete) {
1965: if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
1966: if($obsolete =~ m|(<copyright>)(default)|) {
1967: $rights = 1;
1968: }
1969: }
1970: }
1971: my $tmp = $ulsfn.'&'.join('&',@ulsstats);
1972: if ($obs eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
1973: if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
1974: $ulsout.= &escape($tmp).':';
1975: }
1976: closedir(LSDIR);
1977: }
1978: } else {
1.529 raeburn 1979: unless (($getpropath) || ($getuserdir) ||
1.539 raeburn 1980: ($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) ||
1981: ($ulsdir =~ m{^/home/httpd/html/(?:res|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/}) ||
1982: (($ulsdir =~ m{^/home/httpd/html/priv/$LONCAPA::match_domain/$LONCAPA::match_name/}) && ($islocal))) {
1.529 raeburn 1983: &Failure($client,"refused\n",$userinput);
1984: return 1;
1985: }
1.399 raeburn 1986: my @ulsstats=stat($ulsdir);
1987: $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
1988: }
1989: } else {
1990: $ulsout='no_such_dir';
1.400 raeburn 1991: }
1992: if ($ulsout eq '') { $ulsout='empty'; }
1993: &Reply($client, \$ulsout, $userinput); # This supports debug logging.
1994: return 1;
1.399 raeburn 1995: }
1996: ®ister_handler("ls3", \&ls3_handler, 0, 1, 0);
1.280 matthew 1997:
1.477 raeburn 1998: sub read_lonnet_global {
1999: my ($cmd,$tail,$client) = @_;
2000: my $userinput = "$cmd:$tail";
2001: my $requested = &Apache::lonnet::thaw_unescape($tail);
2002: my $result;
1.480 raeburn 2003: my %packagevars = (
2004: spareid => \%Apache::lonnet::spareid,
2005: perlvar => \%Apache::lonnet::perlvar,
2006: );
2007: my %limit_to = (
2008: perlvar => {
1.531 raeburn 2009: lonOtherAuthen => 1,
2010: lonBalancer => 1,
2011: lonVersion => 1,
2012: lonAdmEMail => 1,
2013: lonSupportEMail => 1,
2014: lonSysEMail => 1,
2015: lonHostID => 1,
2016: lonRole => 1,
2017: lonDefDomain => 1,
2018: lonLoadLim => 1,
2019: lonUserLoadLim => 1,
1.480 raeburn 2020: }
2021: );
1.477 raeburn 2022: if (ref($requested) eq 'HASH') {
2023: foreach my $what (keys(%{$requested})) {
2024: my $response;
1.480 raeburn 2025: my $items = {};
2026: if (exists($packagevars{$what})) {
2027: if (ref($limit_to{$what}) eq 'HASH') {
2028: foreach my $varname (keys(%{$packagevars{$what}})) {
2029: if ($limit_to{$what}{$varname}) {
2030: $items->{$varname} = $packagevars{$what}{$varname};
2031: }
2032: }
2033: } else {
2034: $items = $packagevars{$what};
1.477 raeburn 2035: }
1.480 raeburn 2036: if ($what eq 'perlvar') {
2037: if (!exists($packagevars{$what}{'lonBalancer'})) {
1.559 raeburn 2038: if ($dist =~ /^(centos|rhes|fedora|scientific|oracle)/) {
1.480 raeburn 2039: my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');
2040: if (ref($othervarref) eq 'HASH') {
2041: $items->{'lonBalancer'} = $othervarref->{'lonBalancer'};
2042: }
2043: }
2044: }
1.477 raeburn 2045: }
1.480 raeburn 2046: $response = &Apache::lonnet::freeze_escape($items);
1.477 raeburn 2047: }
1.478 raeburn 2048: $result .= &escape($what).'='.$response.'&';
1.477 raeburn 2049: }
2050: }
2051: $result =~ s/\&$//;
2052: &Reply($client,\$result,$userinput);
2053: return 1;
2054: }
2055: ®ister_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0);
2056:
1.479 raeburn 2057: sub server_devalidatecache_handler {
2058: my ($cmd,$tail,$client) = @_;
2059: my $userinput = "$cmd:$tail";
1.503 raeburn 2060: my $items = &unescape($tail);
2061: my @cached = split(/\&/,$items);
2062: foreach my $key (@cached) {
2063: if ($key =~ /:/) {
2064: my ($name,$id) = map { &unescape($_); } split(/:/,$key);
2065: &Apache::lonnet::devalidate_cache_new($name,$id);
2066: }
2067: }
1.479 raeburn 2068: my $result = 'ok';
2069: &Reply($client,\$result,$userinput);
2070: return 1;
2071: }
1.481 raeburn 2072: ®ister_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0);
1.479 raeburn 2073:
1.410 raeburn 2074: sub server_timezone_handler {
2075: my ($cmd,$tail,$client) = @_;
2076: my $userinput = "$cmd:$tail";
2077: my $timezone;
2078: my $clockfile = '/etc/sysconfig/clock'; # Fedora/CentOS/SuSE
2079: my $tzfile = '/etc/timezone'; # Debian/Ubuntu
2080: if (-e $clockfile) {
2081: if (open(my $fh,"<$clockfile")) {
2082: while (<$fh>) {
2083: next if (/^[\#\s]/);
2084: if (/^(?:TIME)?ZONE\s*=\s*['"]?\s*([\w\/]+)/) {
2085: $timezone = $1;
2086: last;
2087: }
2088: }
2089: close($fh);
2090: }
2091: } elsif (-e $tzfile) {
2092: if (open(my $fh,"<$tzfile")) {
2093: $timezone = <$fh>;
2094: close($fh);
2095: chomp($timezone);
2096: if ($timezone =~ m{^Etc/(\w+)$}) {
2097: $timezone = $1;
2098: }
2099: }
2100: }
2101: &Reply($client,\$timezone,$userinput); # This supports debug logging.
2102: return 1;
2103: }
2104: ®ister_handler("servertimezone", \&server_timezone_handler, 0, 1, 0);
2105:
1.413 raeburn 2106: sub server_loncaparev_handler {
2107: my ($cmd,$tail,$client) = @_;
2108: my $userinput = "$cmd:$tail";
2109: &Reply($client,\$perlvar{'lonVersion'},$userinput);
2110: return 1;
2111: }
2112: ®ister_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);
2113:
1.448 raeburn 2114: sub server_homeID_handler {
2115: my ($cmd,$tail,$client) = @_;
2116: my $userinput = "$cmd:$tail";
2117: &Reply($client,\$perlvar{'lonHostID'},$userinput);
2118: return 1;
2119: }
2120: ®ister_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);
2121:
1.471 raeburn 2122: sub server_distarch_handler {
2123: my ($cmd,$tail,$client) = @_;
2124: my $userinput = "$cmd:$tail";
2125: my $reply = &distro_and_arch();
2126: &Reply($client,\$reply,$userinput);
2127: return 1;
2128: }
2129: ®ister_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0);
2130:
1.523 raeburn 2131: sub server_certs_handler {
2132: my ($cmd,$tail,$client) = @_;
2133: my $userinput = "$cmd:$tail";
1.548 raeburn 2134: my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
2135: my $result = &LONCAPA::Lond::server_certs(\%perlvar,$perlvar{'lonHostID'},$hostname);
1.523 raeburn 2136: &Reply($client,\$result,$userinput);
2137: return;
2138: }
2139: ®ister_handler("servercerts", \&server_certs_handler, 0, 1, 0);
2140:
1.218 foxr 2141: # Process a reinit request. Reinit requests that either
2142: # lonc or lond be reinitialized so that an updated
2143: # host.tab or domain.tab can be processed.
2144: #
2145: # Parameters:
2146: # $cmd - the actual keyword that invoked us.
2147: # $tail - the tail of the request that invoked us.
2148: # $client - File descriptor connected to the client
2149: # Returns:
2150: # 1 - Ok to continue processing.
2151: # 0 - Program should exit
2152: # Implicit output:
2153: # a reply is sent to the client.
2154: #
2155: sub reinit_process_handler {
2156: my ($cmd, $tail, $client) = @_;
2157:
2158: my $userinput = "$cmd:$tail";
2159:
2160: my $cert = &GetCertificate($userinput);
2161: if(&ValidManager($cert)) {
2162: chomp($userinput);
2163: my $reply = &ReinitProcess($userinput);
1.387 albertel 2164: &Reply( $client, \$reply, $userinput);
1.218 foxr 2165: } else {
2166: &Failure( $client, "refused\n", $userinput);
2167: }
2168: return 1;
2169: }
2170: ®ister_handler("reinit", \&reinit_process_handler, 1, 0, 1);
2171:
2172: # Process the editing script for a table edit operation.
2173: # the editing operation must be encrypted and requested by
2174: # a manager host.
2175: #
2176: # Parameters:
2177: # $cmd - the actual keyword that invoked us.
2178: # $tail - the tail of the request that invoked us.
2179: # $client - File descriptor connected to the client
2180: # Returns:
2181: # 1 - Ok to continue processing.
2182: # 0 - Program should exit
2183: # Implicit output:
2184: # a reply is sent to the client.
2185: #
2186: sub edit_table_handler {
2187: my ($command, $tail, $client) = @_;
2188:
2189: my $userinput = "$command:$tail";
2190:
2191: my $cert = &GetCertificate($userinput);
2192: if(&ValidManager($cert)) {
2193: my($filetype, $script) = split(/:/, $tail);
2194: if (($filetype eq "hosts") ||
2195: ($filetype eq "domain")) {
2196: if($script ne "") {
2197: &Reply($client, # BUGBUG - EditFile
2198: &EditFile($userinput), # could fail.
2199: $userinput);
2200: } else {
2201: &Failure($client,"refused\n",$userinput);
2202: }
2203: } else {
2204: &Failure($client,"refused\n",$userinput);
2205: }
2206: } else {
2207: &Failure($client,"refused\n",$userinput);
2208: }
2209: return 1;
2210: }
1.263 albertel 2211: ®ister_handler("edit", \&edit_table_handler, 1, 0, 1);
1.218 foxr 2212:
1.220 foxr 2213: #
2214: # Authenticate a user against the LonCAPA authentication
2215: # database. Note that there are several authentication
2216: # possibilities:
2217: # - unix - The user can be authenticated against the unix
2218: # password file.
2219: # - internal - The user can be authenticated against a purely
2220: # internal per user password file.
2221: # - kerberos - The user can be authenticated against either a kerb4 or kerb5
2222: # ticket granting authority.
2223: # - user - The person tailoring LonCAPA can supply a user authentication
2224: # mechanism that is per system.
2225: #
2226: # Parameters:
2227: # $cmd - The command that got us here.
2228: # $tail - Tail of the command (remaining parameters).
2229: # $client - File descriptor connected to client.
2230: # Returns
2231: # 0 - Requested to exit, caller should shut down.
2232: # 1 - Continue processing.
2233: # Implicit inputs:
2234: # The authentication systems describe above have their own forms of implicit
2235: # input into the authentication process that are described above.
2236: #
2237: sub authenticate_handler {
2238: my ($cmd, $tail, $client) = @_;
2239:
2240:
2241: # Regenerate the full input line
2242:
2243: my $userinput = $cmd.":".$tail;
2244:
2245: # udom - User's domain.
2246: # uname - Username.
2247: # upass - User's password.
1.396 raeburn 2248: # checkdefauth - Pass to validate_user() to try authentication
2249: # with default auth type(s) if no user account.
1.447 raeburn 2250: # clientcancheckhost - Passed by clients with functionality in lonauth.pm
2251: # to check if session can be hosted.
1.220 foxr 2252:
1.447 raeburn 2253: my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
1.399 raeburn 2254: &Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth");
1.220 foxr 2255: chomp($upass);
2256: $upass=&unescape($upass);
2257:
1.396 raeburn 2258: my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
1.220 foxr 2259: if($pwdcorrect) {
1.447 raeburn 2260: my $canhost = 1;
2261: unless ($clientcancheckhost) {
1.448 raeburn 2262: my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
2263: my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
1.452 raeburn 2264: my @intdoms;
2265: my $internet_names = &Apache::lonnet::get_internet_names($clientname);
2266: if (ref($internet_names) eq 'ARRAY') {
2267: @intdoms = @{$internet_names};
2268: }
1.448 raeburn 2269: unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
1.447 raeburn 2270: my ($remote,$hosted);
2271: my $remotesession = &get_usersession_config($udom,'remotesession');
2272: if (ref($remotesession) eq 'HASH') {
1.525 raeburn 2273: $remote = $remotesession->{'remote'};
1.447 raeburn 2274: }
1.448 raeburn 2275: my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession');
1.447 raeburn 2276: if (ref($hostedsession) eq 'HASH') {
2277: $hosted = $hostedsession->{'hosted'};
2278: }
1.448 raeburn 2279: $canhost = &Apache::lonnet::can_host_session($udom,$clientname,
1.492 droeschl 2280: $clientversion,
1.447 raeburn 2281: $remote,$hosted);
2282: }
2283: }
2284: if ($canhost) {
2285: &Reply( $client, "authorized\n", $userinput);
2286: } else {
2287: &Reply( $client, "not_allowed_to_host\n", $userinput);
2288: }
1.220 foxr 2289: #
2290: # Bad credentials: Failed to authorize
2291: #
2292: } else {
2293: &Failure( $client, "non_authorized\n", $userinput);
2294: }
2295:
2296: return 1;
2297: }
1.263 albertel 2298: ®ister_handler("auth", \&authenticate_handler, 1, 1, 0);
1.214 foxr 2299:
1.222 foxr 2300: #
2301: # Change a user's password. Note that this function is complicated by
2302: # the fact that a user may be authenticated in more than one way:
2303: # At present, we are not able to change the password for all types of
2304: # authentication methods. Only for:
2305: # unix - unix password or shadow passoword style authentication.
2306: # local - Locally written authentication mechanism.
2307: # For now, kerb4 and kerb5 password changes are not supported and result
2308: # in an error.
2309: # FUTURE WORK:
2310: # Support kerberos passwd changes?
2311: # Parameters:
2312: # $cmd - The command that got us here.
2313: # $tail - Tail of the command (remaining parameters).
2314: # $client - File descriptor connected to client.
2315: # Returns
2316: # 0 - Requested to exit, caller should shut down.
2317: # 1 - Continue processing.
2318: # Implicit inputs:
2319: # The authentication systems describe above have their own forms of implicit
2320: # input into the authentication process that are described above.
2321: sub change_password_handler {
2322: my ($cmd, $tail, $client) = @_;
2323:
2324: my $userinput = $cmd.":".$tail; # Reconstruct client's string.
2325:
2326: #
2327: # udom - user's domain.
2328: # uname - Username.
2329: # upass - Current password.
2330: # npass - New password.
1.346 raeburn 2331: # context - Context in which this was called
2332: # (preferences or reset_by_email).
1.428 raeburn 2333: # lonhost - HostID of server where request originated
1.222 foxr 2334:
1.428 raeburn 2335: my ($udom,$uname,$upass,$npass,$context,$lonhost)=split(/:/,$tail);
1.222 foxr 2336:
2337: $upass=&unescape($upass);
2338: $npass=&unescape($npass);
2339: &Debug("Trying to change password for $uname");
2340:
2341: # First require that the user can be authenticated with their
1.346 raeburn 2342: # old password unless context was 'reset_by_email':
2343:
1.428 raeburn 2344: my ($validated,$failure);
1.346 raeburn 2345: if ($context eq 'reset_by_email') {
1.428 raeburn 2346: if ($lonhost eq '') {
2347: $failure = 'invalid_client';
2348: } else {
2349: $validated = 1;
2350: }
1.346 raeburn 2351: } else {
2352: $validated = &validate_user($udom, $uname, $upass);
2353: }
1.222 foxr 2354: if($validated) {
2355: my $realpasswd = &get_auth_type($udom, $uname); # Defined since authd.
2356: my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
1.558 raeburn 2357: my $notunique;
1.222 foxr 2358: if ($howpwd eq 'internal') {
2359: &Debug("internal auth");
1.518 raeburn 2360: my $ncpass = &hash_passwd($udom,$npass);
1.558 raeburn 2361: my (undef,$method,@rest) = split(/!/,$contentpwd);
2362: if ($method eq 'bcrypt') {
2363: my %passwdconf = &Apache::lonnet::get_passwdconf($udom);
2364: if (($passwdconf{'numsaved'}) && ($passwdconf{'numsaved'} =~ /^\d+$/)) {
2365: my @oldpasswds;
2366: my $userpath = &propath($udom,$uname);
2367: my $fullpath = $userpath.'/oldpasswds';
2368: if (-d $userpath) {
2369: my @oldfiles;
2370: if (-e $fullpath) {
2371: if (opendir(my $dir,$fullpath)) {
2372: (@oldfiles) = grep(/^\d+$/,readdir($dir));
2373: closedir($dir);
2374: }
2375: if (@oldfiles) {
2376: @oldfiles = sort { $b <=> $a } (@oldfiles);
2377: my $numremoved = 0;
2378: for (my $i=0; $i<@oldfiles; $i++) {
2379: if ($i>=$passwdconf{'numsaved'}) {
2380: if (-f "$fullpath/$oldfiles[$i]") {
2381: if (unlink("$fullpath/$oldfiles[$i]")) {
2382: $numremoved ++;
2383: }
2384: }
2385: } elsif (open(my $fh,'<',"$fullpath/$oldfiles[$i]")) {
2386: while (my $line = <$fh>) {
2387: push(@oldpasswds,$line);
2388: }
2389: close($fh);
2390: }
2391: }
2392: if ($numremoved) {
2393: &logthis("unlinked $numremoved old password files for $uname:$udom");
2394: }
2395: }
2396: }
2397: push(@oldpasswds,$contentpwd);
2398: foreach my $item (@oldpasswds) {
2399: my (undef,$method,@rest) = split(/!/,$item);
2400: if ($method eq 'bcrypt') {
2401: my $result = &hash_passwd($udom,$npass,@rest);
2402: if ($result eq $item) {
2403: $notunique = 1;
2404: last;
2405: }
2406: }
2407: }
2408: unless ($notunique) {
2409: unless (-e $fullpath) {
2410: if (&mkpath("$fullpath/")) {
2411: chmod(0700,$fullpath);
2412: }
2413: }
2414: if (-d $fullpath) {
2415: my $now = time;
2416: if (open(my $fh,'>',"$fullpath/$now")) {
2417: print $fh $contentpwd;
2418: close($fh);
2419: chmod(0400,"$fullpath/$now");
2420: }
2421: }
2422: }
2423: }
2424: }
2425: }
2426: if ($notunique) {
2427: my $msg="Result of password change for $uname:$udom - password matches one used before";
2428: if ($lonhost) {
2429: $msg .= " - request originated from: $lonhost";
2430: }
2431: &logthis($msg);
2432: &Reply($client, "prioruse\n", $userinput);
2433: } elsif (&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
1.428 raeburn 2434: my $msg="Result of password change for $uname: pwchange_success";
2435: if ($lonhost) {
2436: $msg .= " - request originated from: $lonhost";
2437: }
2438: &logthis($msg);
1.518 raeburn 2439: &update_passwd_history($uname,$udom,$howpwd,$context);
1.222 foxr 2440: &Reply($client, "ok\n", $userinput);
2441: } else {
2442: &logthis("Unable to open $uname passwd "
2443: ."to change password");
2444: &Failure( $client, "non_authorized\n",$userinput);
2445: }
1.346 raeburn 2446: } elsif ($howpwd eq 'unix' && $context ne 'reset_by_email') {
1.287 foxr 2447: my $result = &change_unix_password($uname, $npass);
1.518 raeburn 2448: if ($result eq 'ok') {
2449: &update_passwd_history($uname,$udom,$howpwd,$context);
1.561 raeburn 2450: }
1.222 foxr 2451: &logthis("Result of password change for $uname: ".
1.287 foxr 2452: $result);
1.387 albertel 2453: &Reply($client, \$result, $userinput);
1.222 foxr 2454: } else {
2455: # this just means that the current password mode is not
2456: # one we know how to change (e.g the kerberos auth modes or
2457: # locally written auth handler).
2458: #
2459: &Failure( $client, "auth_mode_error\n", $userinput);
2460: }
1.224 foxr 2461: } else {
1.428 raeburn 2462: if ($failure eq '') {
2463: $failure = 'non_authorized';
2464: }
2465: &Failure( $client, "$failure\n", $userinput);
1.222 foxr 2466: }
2467:
2468: return 1;
2469: }
1.263 albertel 2470: ®ister_handler("passwd", \&change_password_handler, 1, 1, 0);
1.222 foxr 2471:
1.518 raeburn 2472: sub hash_passwd {
2473: my ($domain,$plainpass,@rest) = @_;
2474: my ($salt,$cost);
2475: if (@rest) {
2476: $cost = $rest[0];
2477: # salt is first 22 characters, base-64 encoded by bcrypt
2478: my $plainsalt = substr($rest[1],0,22);
2479: $salt = Crypt::Eksblowfish::Bcrypt::de_base64($plainsalt);
2480: } else {
1.533 raeburn 2481: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
2482: my $defaultcost = $domdefaults{'intauth_cost'};
1.518 raeburn 2483: if (($defaultcost eq '') || ($defaultcost =~ /D/)) {
2484: $cost = 10;
2485: } else {
2486: $cost = $defaultcost;
2487: }
2488: # Generate random 16-octet base64 salt
2489: $salt = "";
2490: $salt .= pack("C", int rand(256)) for 1..16;
2491: }
2492: my $hash = &Crypt::Eksblowfish::Bcrypt::bcrypt_hash({
2493: key_nul => 1,
2494: cost => $cost,
2495: salt => $salt,
2496: }, Digest::SHA::sha512(Encode::encode('UTF-8',$plainpass)));
2497:
2498: my $result = join("!", "", "bcrypt", sprintf("%02d",$cost),
2499: &Crypt::Eksblowfish::Bcrypt::en_base64($salt).
2500: &Crypt::Eksblowfish::Bcrypt::en_base64($hash));
2501: return $result;
2502: }
2503:
1.225 foxr 2504: #
2505: # Create a new user. User in this case means a lon-capa user.
2506: # The user must either already exist in some authentication realm
2507: # like kerberos or the /etc/passwd. If not, a user completely local to
2508: # this loncapa system is created.
2509: #
2510: # Parameters:
2511: # $cmd - The command that got us here.
2512: # $tail - Tail of the command (remaining parameters).
2513: # $client - File descriptor connected to client.
2514: # Returns
2515: # 0 - Requested to exit, caller should shut down.
2516: # 1 - Continue processing.
2517: # Implicit inputs:
2518: # The authentication systems describe above have their own forms of implicit
2519: # input into the authentication process that are described above.
2520: sub add_user_handler {
2521:
2522: my ($cmd, $tail, $client) = @_;
2523:
2524:
2525: my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
2526: my $userinput = $cmd.":".$tail; # Reconstruct the full request line.
2527:
2528: &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);
2529:
2530:
2531: if($udom eq $currentdomainid) { # Reject new users for other domains...
2532:
2533: my $oldumask=umask(0077);
2534: chomp($npass);
2535: $npass=&unescape($npass);
2536: my $passfilename = &password_path($udom, $uname);
2537: &Debug("Password file created will be:".$passfilename);
2538: if (-e $passfilename) {
2539: &Failure( $client, "already_exists\n", $userinput);
2540: } else {
2541: my $fperror='';
1.264 albertel 2542: if (!&mkpath($passfilename)) {
2543: $fperror="error: ".($!+0)." mkdir failed while attempting "
2544: ."makeuser";
1.225 foxr 2545: }
2546: unless ($fperror) {
1.518 raeburn 2547: my $result=&make_passwd_file($uname,$udom,$umode,$npass,
2548: $passfilename,'makeuser');
1.390 raeburn 2549: &Reply($client,\$result, $userinput); #BUGBUG - could be fail
1.225 foxr 2550: } else {
1.387 albertel 2551: &Failure($client, \$fperror, $userinput);
1.225 foxr 2552: }
2553: }
2554: umask($oldumask);
2555: } else {
2556: &Failure($client, "not_right_domain\n",
2557: $userinput); # Even if we are multihomed.
2558:
2559: }
2560: return 1;
2561:
2562: }
2563: ®ister_handler("makeuser", \&add_user_handler, 1, 1, 0);
2564:
2565: #
2566: # Change the authentication method of a user. Note that this may
2567: # also implicitly change the user's password if, for example, the user is
2568: # joining an existing authentication realm. Known authentication realms at
2569: # this time are:
2570: # internal - Purely internal password file (only loncapa knows this user)
2571: # local - Institutionally written authentication module.
2572: # unix - Unix user (/etc/passwd with or without /etc/shadow).
2573: # kerb4 - kerberos version 4
2574: # kerb5 - kerberos version 5
2575: #
2576: # Parameters:
2577: # $cmd - The command that got us here.
2578: # $tail - Tail of the command (remaining parameters).
2579: # $client - File descriptor connected to client.
2580: # Returns
2581: # 0 - Requested to exit, caller should shut down.
2582: # 1 - Continue processing.
2583: # Implicit inputs:
2584: # The authentication systems describe above have their own forms of implicit
2585: # input into the authentication process that are described above.
1.287 foxr 2586: # NOTE:
2587: # This is also used to change the authentication credential values (e.g. passwd).
2588: #
1.225 foxr 2589: #
2590: sub change_authentication_handler {
2591:
2592: my ($cmd, $tail, $client) = @_;
2593:
2594: my $userinput = "$cmd:$tail"; # Reconstruct user input.
2595:
2596: my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
2597: &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode);
2598: if ($udom ne $currentdomainid) {
2599: &Failure( $client, "not_right_domain\n", $client);
2600: } else {
2601:
2602: chomp($npass);
2603:
2604: $npass=&unescape($npass);
1.261 foxr 2605: my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.
1.225 foxr 2606: my $passfilename = &password_path($udom, $uname);
2607: if ($passfilename) { # Not allowed to create a new user!!
1.287 foxr 2608: # If just changing the unix passwd. need to arrange to run
1.502 raeburn 2609: # passwd since otherwise make_passwd_file will fail as
2610: # creation of unix authenticated users is no longer supported
2611: # except from the command line, when running make_domain_coordinator.pl
1.287 foxr 2612:
2613: if(($oldauth =~/^unix/) && ($umode eq "unix")) {
2614: my $result = &change_unix_password($uname, $npass);
2615: &logthis("Result of password change for $uname: ".$result);
2616: if ($result eq "ok") {
1.518 raeburn 2617: &update_passwd_history($uname,$udom,$umode,'changeuserauth');
1.390 raeburn 2618: &Reply($client, \$result);
1.288 albertel 2619: } else {
1.387 albertel 2620: &Failure($client, \$result);
1.287 foxr 2621: }
1.288 albertel 2622: } else {
1.518 raeburn 2623: my $result=&make_passwd_file($uname,$udom,$umode,$npass,
2624: $passfilename,'changeuserauth');
1.287 foxr 2625: #
2626: # If the current auth mode is internal, and the old auth mode was
2627: # unix, or krb*, and the user is an author for this domain,
2628: # re-run manage_permissions for that role in order to be able
2629: # to take ownership of the construction space back to www:www
2630: #
1.502 raeburn 2631:
2632:
1.387 albertel 2633: &Reply($client, \$result, $userinput);
1.261 foxr 2634: }
2635:
2636:
1.225 foxr 2637: } else {
1.251 foxr 2638: &Failure($client, "non_authorized\n", $userinput); # Fail the user now.
1.225 foxr 2639: }
2640: }
2641: return 1;
2642: }
2643: ®ister_handler("changeuserauth", \&change_authentication_handler, 1,1, 0);
2644:
1.518 raeburn 2645: sub update_passwd_history {
2646: my ($uname,$udom,$umode,$context) = @_;
2647: my $proname=&propath($udom,$uname);
2648: my $now = time;
2649: if (open(my $fh,">>$proname/passwd.log")) {
2650: print $fh "$now:$umode:$context\n";
2651: close($fh);
2652: }
2653: return;
2654: }
2655:
1.225 foxr 2656: #
2657: # Determines if this is the home server for a user. The home server
2658: # for a user will have his/her lon-capa passwd file. Therefore all we need
2659: # to do is determine if this file exists.
2660: #
2661: # Parameters:
2662: # $cmd - The command that got us here.
2663: # $tail - Tail of the command (remaining parameters).
2664: # $client - File descriptor connected to client.
2665: # Returns
2666: # 0 - Requested to exit, caller should shut down.
2667: # 1 - Continue processing.
2668: # Implicit inputs:
2669: # The authentication systems describe above have their own forms of implicit
2670: # input into the authentication process that are described above.
2671: #
2672: sub is_home_handler {
2673: my ($cmd, $tail, $client) = @_;
2674:
2675: my $userinput = "$cmd:$tail";
2676:
2677: my ($udom,$uname)=split(/:/,$tail);
2678: chomp($uname);
2679: my $passfile = &password_filename($udom, $uname);
2680: if($passfile) {
2681: &Reply( $client, "found\n", $userinput);
2682: } else {
2683: &Failure($client, "not_found\n", $userinput);
2684: }
2685: return 1;
2686: }
2687: ®ister_handler("home", \&is_home_handler, 0,1,0);
2688:
2689: #
1.434 www 2690: # Process an update request for a resource.
2691: # A resource has been modified that we hold a subscription to.
1.225 foxr 2692: # If the resource is not local, then we must update, or at least invalidate our
2693: # cached copy of the resource.
2694: # Parameters:
2695: # $cmd - The command that got us here.
2696: # $tail - Tail of the command (remaining parameters).
2697: # $client - File descriptor connected to client.
2698: # Returns
2699: # 0 - Requested to exit, caller should shut down.
2700: # 1 - Continue processing.
2701: # Implicit inputs:
2702: # The authentication systems describe above have their own forms of implicit
2703: # input into the authentication process that are described above.
2704: #
2705: sub update_resource_handler {
2706:
2707: my ($cmd, $tail, $client) = @_;
2708:
2709: my $userinput = "$cmd:$tail";
2710:
2711: my $fname= $tail; # This allows interactive testing
2712:
2713:
2714: my $ownership=ishome($fname);
2715: if ($ownership eq 'not_owner') {
2716: if (-e $fname) {
1.434 www 2717: # Delete preview file, if exists
2718: unlink("$fname.tmp");
2719: # Get usage stats
1.225 foxr 2720: my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
2721: $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
2722: my $now=time;
2723: my $since=$now-$atime;
1.434 www 2724: # If the file has not been used within lonExpire seconds,
2725: # unsubscribe from it and delete local copy
1.225 foxr 2726: if ($since>$perlvar{'lonExpire'}) {
1.365 albertel 2727: my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
1.308 albertel 2728: &devalidate_meta_cache($fname);
1.225 foxr 2729: unlink("$fname");
1.334 albertel 2730: unlink("$fname.meta");
1.225 foxr 2731: } else {
1.434 www 2732: # Yes, this is in active use. Get a fresh copy. Since it might be in
2733: # very active use and huge (like a movie), copy it to "in.transfer" filename first.
1.225 foxr 2734: my $transname="$fname.in.transfer";
1.365 albertel 2735: my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
1.225 foxr 2736: my $response;
1.537 raeburn 2737: # FIXME: cannot replicate files that take more than two minutes to transfer -- needs checking now 1200s timeout used
2738: # for LWP request.
2739: my $request=new HTTP::Request('GET',"$remoteurl");
2740: $response=&LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,0,1);
1.225 foxr 2741: if ($response->is_error()) {
1.541 raeburn 2742: my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
2743: &devalidate_meta_cache($fname);
2744: if (-e $transname) {
2745: unlink($transname);
2746: }
2747: unlink($fname);
1.225 foxr 2748: my $message=$response->status_line;
2749: &logthis("LWP GET: $message for $fname ($remoteurl)");
2750: } else {
2751: if ($remoteurl!~/\.meta$/) {
1.537 raeburn 2752: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
2753: my $mresponse = &LONCAPA::LWPReq::makerequest($clientname,$mrequest,$fname.'.meta',\%perlvar,120,0,1);
2754: if ($mresponse->is_error()) {
2755: unlink($fname.'.meta');
1.225 foxr 2756: }
2757: }
1.434 www 2758: # we successfully transfered, copy file over to real name
1.225 foxr 2759: rename($transname,$fname);
1.308 albertel 2760: &devalidate_meta_cache($fname);
1.225 foxr 2761: }
2762: }
2763: &Reply( $client, "ok\n", $userinput);
2764: } else {
2765: &Failure($client, "not_found\n", $userinput);
2766: }
2767: } else {
2768: &Failure($client, "rejected\n", $userinput);
2769: }
2770: return 1;
2771: }
2772: ®ister_handler("update", \&update_resource_handler, 0 ,1, 0);
2773:
1.308 albertel 2774: sub devalidate_meta_cache {
2775: my ($url) = @_;
2776: use Cache::Memcached;
2777: my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
1.365 albertel 2778: $url = &Apache::lonnet::declutter($url);
1.308 albertel 2779: $url =~ s-\.meta$--;
2780: my $id = &escape('meta:'.$url);
2781: $memcache->delete($id);
2782: }
2783:
1.225 foxr 2784: #
1.226 foxr 2785: # Fetch a user file from a remote server to the user's home directory
2786: # userfiles subdir.
1.225 foxr 2787: # Parameters:
2788: # $cmd - The command that got us here.
2789: # $tail - Tail of the command (remaining parameters).
2790: # $client - File descriptor connected to client.
2791: # Returns
2792: # 0 - Requested to exit, caller should shut down.
2793: # 1 - Continue processing.
2794: #
2795: sub fetch_user_file_handler {
2796:
2797: my ($cmd, $tail, $client) = @_;
2798:
2799: my $userinput = "$cmd:$tail";
2800: my $fname = $tail;
1.232 foxr 2801: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
1.225 foxr 2802: my $udir=&propath($udom,$uname).'/userfiles';
2803: unless (-e $udir) {
2804: mkdir($udir,0770);
2805: }
1.232 foxr 2806: Debug("fetch user file for $fname");
1.225 foxr 2807: if (-e $udir) {
2808: $ufile=~s/^[\.\~]+//;
1.232 foxr 2809:
2810: # IF necessary, create the path right down to the file.
2811: # Note that any regular files in the way of this path are
2812: # wiped out to deal with some earlier folly of mine.
2813:
1.267 raeburn 2814: if (!&mkpath($udir.'/'.$ufile)) {
1.264 albertel 2815: &Failure($client, "unable_to_create\n", $userinput);
1.232 foxr 2816: }
2817:
1.225 foxr 2818: my $destname=$udir.'/'.$ufile;
2819: my $transname=$udir.'/'.$ufile.'.in.transit';
1.476 raeburn 2820: my $clientprotocol=$Apache::lonnet::protocol{$clientname};
2821: $clientprotocol = 'http' if ($clientprotocol ne 'https');
1.486 raeburn 2822: my $clienthost = &Apache::lonnet::hostname($clientname);
2823: my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
1.225 foxr 2824: my $response;
1.232 foxr 2825: Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
1.537 raeburn 2826: my $request=new HTTP::Request('GET',"$remoteurl");
2827: my $verifycert = 1;
2828: my @machine_ids = &Apache::lonnet::current_machine_ids();
2829: if (grep(/^\Q$clientname\E$/,@machine_ids)) {
2830: $verifycert = 0;
2831: }
2832: $response = &LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,$verifycert);
1.225 foxr 2833: if ($response->is_error()) {
2834: unlink($transname);
2835: my $message=$response->status_line;
2836: &logthis("LWP GET: $message for $fname ($remoteurl)");
2837: &Failure($client, "failed\n", $userinput);
2838: } else {
1.232 foxr 2839: Debug("Renaming $transname to $destname");
1.225 foxr 2840: if (!rename($transname,$destname)) {
2841: &logthis("Unable to move $transname to $destname");
2842: unlink($transname);
2843: &Failure($client, "failed\n", $userinput);
2844: } else {
1.495 raeburn 2845: if ($fname =~ /^default.+\.(page|sequence)$/) {
2846: my ($major,$minor) = split(/\./,$clientversion);
2847: if (($major < 2) || ($major == 2 && $minor < 11)) {
2848: my $now = time;
2849: &Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600);
2850: my $key = &escape('internal.contentchange');
2851: my $what = "$key=$now";
2852: my $hashref = &tie_user_hash($udom,$uname,'environment',
2853: &GDBM_WRCREAT(),"P",$what);
2854: if ($hashref) {
2855: $hashref->{$key}=$now;
2856: if (!&untie_user_hash($hashref)) {
2857: &logthis("error: ".($!+0)." untie (GDBM) failed ".
2858: "when updating internal.contentchange");
2859: }
2860: }
2861: }
2862: }
1.225 foxr 2863: &Reply($client, "ok\n", $userinput);
2864: }
2865: }
2866: } else {
2867: &Failure($client, "not_home\n", $userinput);
2868: }
2869: return 1;
2870: }
2871: ®ister_handler("fetchuserfile", \&fetch_user_file_handler, 0, 1, 0);
2872:
1.226 foxr 2873: #
2874: # Remove a file from a user's home directory userfiles subdirectory.
2875: # Parameters:
2876: # cmd - the Lond request keyword that got us here.
2877: # tail - the part of the command past the keyword.
2878: # client- File descriptor connected with the client.
2879: #
2880: # Returns:
2881: # 1 - Continue processing.
2882: sub remove_user_file_handler {
2883: my ($cmd, $tail, $client) = @_;
2884:
2885: my ($fname) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
2886:
2887: my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
2888: if ($ufile =~m|/\.\./|) {
2889: # any files paths with /../ in them refuse
2890: # to deal with
2891: &Failure($client, "refused\n", "$cmd:$tail");
2892: } else {
2893: my $udir = &propath($udom,$uname);
2894: if (-e $udir) {
2895: my $file=$udir.'/userfiles/'.$ufile;
2896: if (-e $file) {
1.253 foxr 2897: #
2898: # If the file is a regular file unlink is fine...
1.520 raeburn 2899: # However it's possible the client wants a dir
2900: # removed, in which case rmdir is more appropriate.
2901: # Note: rmdir will only remove an empty directory.
1.253 foxr 2902: #
1.240 banghart 2903: if (-f $file){
1.241 albertel 2904: unlink($file);
1.520 raeburn 2905: # for html files remove the associated .bak file
2906: # which may have been created by the editor.
2907: if ($ufile =~ m{^((docs|supplemental)/(?:\d+|default)/\d+(?:|/.+)/)[^/]+\.x?html?$}i) {
2908: my $path = $1;
2909: if (-e $file.'.bak') {
2910: unlink($file.'.bak');
2911: }
2912: }
1.241 albertel 2913: } elsif(-d $file) {
2914: rmdir($file);
1.240 banghart 2915: }
1.226 foxr 2916: if (-e $file) {
1.253 foxr 2917: # File is still there after we deleted it ?!?
2918:
1.226 foxr 2919: &Failure($client, "failed\n", "$cmd:$tail");
2920: } else {
2921: &Reply($client, "ok\n", "$cmd:$tail");
2922: }
2923: } else {
2924: &Failure($client, "not_found\n", "$cmd:$tail");
2925: }
2926: } else {
2927: &Failure($client, "not_home\n", "$cmd:$tail");
2928: }
2929: }
2930: return 1;
2931: }
2932: ®ister_handler("removeuserfile", \&remove_user_file_handler, 0,1,0);
2933:
1.236 albertel 2934: #
2935: # make a directory in a user's home directory userfiles subdirectory.
2936: # Parameters:
2937: # cmd - the Lond request keyword that got us here.
2938: # tail - the part of the command past the keyword.
2939: # client- File descriptor connected with the client.
2940: #
2941: # Returns:
2942: # 1 - Continue processing.
2943: sub mkdir_user_file_handler {
2944: my ($cmd, $tail, $client) = @_;
2945:
2946: my ($dir) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
2947: $dir=&unescape($dir);
2948: my ($udom,$uname,$ufile) = ($dir =~ m|^([^/]+)/([^/]+)/(.+)$|);
2949: if ($ufile =~m|/\.\./|) {
2950: # any files paths with /../ in them refuse
2951: # to deal with
2952: &Failure($client, "refused\n", "$cmd:$tail");
2953: } else {
2954: my $udir = &propath($udom,$uname);
2955: if (-e $udir) {
1.264 albertel 2956: my $newdir=$udir.'/userfiles/'.$ufile.'/';
2957: if (!&mkpath($newdir)) {
2958: &Failure($client, "failed\n", "$cmd:$tail");
1.236 albertel 2959: }
1.264 albertel 2960: &Reply($client, "ok\n", "$cmd:$tail");
1.236 albertel 2961: } else {
2962: &Failure($client, "not_home\n", "$cmd:$tail");
2963: }
2964: }
2965: return 1;
2966: }
2967: ®ister_handler("mkdiruserfile", \&mkdir_user_file_handler, 0,1,0);
2968:
1.237 albertel 2969: #
2970: # rename a file in a user's home directory userfiles subdirectory.
2971: # Parameters:
2972: # cmd - the Lond request keyword that got us here.
2973: # tail - the part of the command past the keyword.
2974: # client- File descriptor connected with the client.
2975: #
2976: # Returns:
2977: # 1 - Continue processing.
2978: sub rename_user_file_handler {
2979: my ($cmd, $tail, $client) = @_;
2980:
2981: my ($udom,$uname,$old,$new) = split(/:/, $tail);
2982: $old=&unescape($old);
2983: $new=&unescape($new);
2984: if ($new =~m|/\.\./| || $old =~m|/\.\./|) {
2985: # any files paths with /../ in them refuse to deal with
2986: &Failure($client, "refused\n", "$cmd:$tail");
2987: } else {
2988: my $udir = &propath($udom,$uname);
2989: if (-e $udir) {
2990: my $oldfile=$udir.'/userfiles/'.$old;
2991: my $newfile=$udir.'/userfiles/'.$new;
2992: if (-e $newfile) {
2993: &Failure($client, "exists\n", "$cmd:$tail");
2994: } elsif (! -e $oldfile) {
2995: &Failure($client, "not_found\n", "$cmd:$tail");
2996: } else {
2997: if (!rename($oldfile,$newfile)) {
2998: &Failure($client, "failed\n", "$cmd:$tail");
2999: } else {
3000: &Reply($client, "ok\n", "$cmd:$tail");
3001: }
3002: }
3003: } else {
3004: &Failure($client, "not_home\n", "$cmd:$tail");
3005: }
3006: }
3007: return 1;
3008: }
3009: ®ister_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
3010:
1.227 foxr 3011: #
1.382 albertel 3012: # Checks if the specified user has an active session on the server
3013: # return ok if so, not_found if not
3014: #
3015: # Parameters:
3016: # cmd - The request keyword that dispatched to tus.
3017: # tail - The tail of the request (colon separated parameters).
3018: # client - Filehandle open on the client.
3019: # Return:
3020: # 1.
3021: sub user_has_session_handler {
3022: my ($cmd, $tail, $client) = @_;
3023:
3024: my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
3025:
3026: opendir(DIR,$perlvar{'lonIDsDir'});
3027: my $filename;
3028: while ($filename=readdir(DIR)) {
3029: last if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/);
3030: }
3031: if ($filename) {
3032: &Reply($client, "ok\n", "$cmd:$tail");
3033: } else {
3034: &Failure($client, "not_found\n", "$cmd:$tail");
3035: }
3036: return 1;
3037:
3038: }
3039: ®ister_handler("userhassession", \&user_has_session_handler, 0,1,0);
3040:
1.560 raeburn 3041: sub del_usersession_handler {
3042: my ($cmd, $tail, $client) = @_;
3043:
3044: my $result;
3045: my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
3046: if (($udom =~ /^$LONCAPA::match_domain$/) && ($uname =~ /^$LONCAPA::match_username$/)) {
3047: my $lonidsdir = $perlvar{'lonIDsDir'};
3048: if (-d $lonidsdir) {
3049: if (opendir(DIR,$lonidsdir)) {
3050: my $filename;
3051: while ($filename=readdir(DIR)) {
3052: if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/) {
3053: if (tie(my %oldenv,'GDBM_File',"$lonidsdir/$filename",
3054: &GDBM_READER(),0640)) {
3055: my $linkedfile;
3056: if (exists($oldenv{'user.linkedenv'})) {
3057: $linkedfile = $oldenv{'user.linkedenv'};
3058: }
3059: untie(%oldenv);
3060: $result = unlink("$lonidsdir/$filename");
3061: if ($result) {
3062: if ($linkedfile =~ /^[a-f0-9]+_linked$/) {
3063: if (-l "$lonidsdir/$linkedfile.id") {
3064: unlink("$lonidsdir/$linkedfile.id");
3065: }
3066: }
3067: }
3068: } else {
3069: $result = unlink("$lonidsdir/$filename");
3070: }
3071: last;
3072: }
3073: }
3074: }
3075: }
3076: if ($result == 1) {
3077: &Reply($client, "$result\n", "$cmd:$tail");
3078: } else {
3079: &Reply($client, "not_found\n", "$cmd:$tail");
3080: }
3081: } else {
3082: &Failure($client, "invalid_user\n", "$cmd:$tail");
3083: }
3084: return 1;
3085: }
3086:
3087: ®ister_handler("delusersession", \&del_usersession_handler, 0,1,0);
3088:
1.382 albertel 3089: #
1.263 albertel 3090: # Authenticate access to a user file by checking that the token the user's
3091: # passed also exists in their session file
1.227 foxr 3092: #
3093: # Parameters:
3094: # cmd - The request keyword that dispatched to tus.
3095: # tail - The tail of the request (colon separated parameters).
3096: # client - Filehandle open on the client.
3097: # Return:
3098: # 1.
3099: sub token_auth_user_file_handler {
3100: my ($cmd, $tail, $client) = @_;
3101:
3102: my ($fname, $session) = split(/:/, $tail);
3103:
3104: chomp($session);
1.393 raeburn 3105: my $reply="non_auth";
1.343 albertel 3106: my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
3107: if (open(ENVIN,"$file")) {
1.332 albertel 3108: flock(ENVIN,LOCK_SH);
1.343 albertel 3109: tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
3110: if (exists($disk_env{"userfile.$fname"})) {
1.393 raeburn 3111: $reply="ok";
1.343 albertel 3112: } else {
3113: foreach my $envname (keys(%disk_env)) {
3114: if ($envname=~ m|^userfile\.\Q$fname\E|) {
1.393 raeburn 3115: $reply="ok";
1.343 albertel 3116: last;
3117: }
3118: }
1.227 foxr 3119: }
1.343 albertel 3120: untie(%disk_env);
1.227 foxr 3121: close(ENVIN);
1.387 albertel 3122: &Reply($client, \$reply, "$cmd:$tail");
1.227 foxr 3123: } else {
3124: &Failure($client, "invalid_token\n", "$cmd:$tail");
3125: }
3126: return 1;
3127:
3128: }
3129: ®ister_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
1.229 foxr 3130:
3131: #
3132: # Unsubscribe from a resource.
3133: #
3134: # Parameters:
3135: # $cmd - The command that got us here.
3136: # $tail - Tail of the command (remaining parameters).
3137: # $client - File descriptor connected to client.
3138: # Returns
3139: # 0 - Requested to exit, caller should shut down.
3140: # 1 - Continue processing.
3141: #
3142: sub unsubscribe_handler {
3143: my ($cmd, $tail, $client) = @_;
3144:
3145: my $userinput= "$cmd:$tail";
3146:
3147: my ($fname) = split(/:/,$tail); # Split in case there's extrs.
3148:
3149: &Debug("Unsubscribing $fname");
3150: if (-e $fname) {
3151: &Debug("Exists");
3152: &Reply($client, &unsub($fname,$clientip), $userinput);
3153: } else {
3154: &Failure($client, "not_found\n", $userinput);
3155: }
3156: return 1;
3157: }
3158: ®ister_handler("unsub", \&unsubscribe_handler, 0, 1, 0);
1.263 albertel 3159:
1.230 foxr 3160: # Subscribe to a resource
3161: #
3162: # Parameters:
3163: # $cmd - The command that got us here.
3164: # $tail - Tail of the command (remaining parameters).
3165: # $client - File descriptor connected to client.
3166: # Returns
3167: # 0 - Requested to exit, caller should shut down.
3168: # 1 - Continue processing.
3169: #
3170: sub subscribe_handler {
3171: my ($cmd, $tail, $client)= @_;
3172:
3173: my $userinput = "$cmd:$tail";
3174:
3175: &Reply( $client, &subscribe($userinput,$clientip), $userinput);
3176:
3177: return 1;
3178: }
3179: ®ister_handler("sub", \&subscribe_handler, 0, 1, 0);
3180:
3181: #
1.379 albertel 3182: # Determine the latest version of a resource (it looks for the highest
3183: # past version and then returns that +1)
1.230 foxr 3184: #
3185: # Parameters:
3186: # $cmd - The command that got us here.
3187: # $tail - Tail of the command (remaining parameters).
1.379 albertel 3188: # (Should consist of an absolute path to a file)
1.230 foxr 3189: # $client - File descriptor connected to client.
3190: # Returns
3191: # 0 - Requested to exit, caller should shut down.
3192: # 1 - Continue processing.
3193: #
3194: sub current_version_handler {
3195: my ($cmd, $tail, $client) = @_;
3196:
3197: my $userinput= "$cmd:$tail";
3198:
3199: my $fname = $tail;
3200: &Reply( $client, ¤tversion($fname)."\n", $userinput);
3201: return 1;
3202:
3203: }
3204: ®ister_handler("currentversion", \¤t_version_handler, 0, 1, 0);
3205:
3206: # Make an entry in a user's activity log.
3207: #
3208: # Parameters:
3209: # $cmd - The command that got us here.
3210: # $tail - Tail of the command (remaining parameters).
3211: # $client - File descriptor connected to client.
3212: # Returns
3213: # 0 - Requested to exit, caller should shut down.
3214: # 1 - Continue processing.
3215: #
3216: sub activity_log_handler {
3217: my ($cmd, $tail, $client) = @_;
3218:
3219:
3220: my $userinput= "$cmd:$tail";
3221:
3222: my ($udom,$uname,$what)=split(/:/,$tail);
3223: chomp($what);
3224: my $proname=&propath($udom,$uname);
3225: my $now=time;
3226: my $hfh;
3227: if ($hfh=IO::File->new(">>$proname/activity.log")) {
3228: print $hfh "$now:$clientname:$what\n";
3229: &Reply( $client, "ok\n", $userinput);
3230: } else {
3231: &Failure($client, "error: ".($!+0)." IO::File->new Failed "
3232: ."while attempting log\n",
3233: $userinput);
3234: }
3235:
3236: return 1;
3237: }
1.263 albertel 3238: ®ister_handler("log", \&activity_log_handler, 0, 1, 0);
1.230 foxr 3239:
3240: #
3241: # Put a namespace entry in a user profile hash.
3242: # My druthers would be for this to be an encrypted interaction too.
3243: # anything that might be an inadvertent covert channel about either
3244: # user authentication or user personal information....
3245: #
3246: # Parameters:
3247: # $cmd - The command that got us here.
3248: # $tail - Tail of the command (remaining parameters).
3249: # $client - File descriptor connected to client.
3250: # Returns
3251: # 0 - Requested to exit, caller should shut down.
3252: # 1 - Continue processing.
3253: #
3254: sub put_user_profile_entry {
3255: my ($cmd, $tail, $client) = @_;
1.229 foxr 3256:
1.230 foxr 3257: my $userinput = "$cmd:$tail";
3258:
1.242 raeburn 3259: my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
1.230 foxr 3260: if ($namespace ne 'roles') {
3261: chomp($what);
3262: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3263: &GDBM_WRCREAT(),"P",$what);
3264: if($hashref) {
3265: my @pairs=split(/\&/,$what);
3266: foreach my $pair (@pairs) {
3267: my ($key,$value)=split(/=/,$pair);
3268: $hashref->{$key}=$value;
3269: }
1.311 albertel 3270: if (&untie_user_hash($hashref)) {
1.230 foxr 3271: &Reply( $client, "ok\n", $userinput);
3272: } else {
3273: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
3274: "while attempting put\n",
3275: $userinput);
3276: }
3277: } else {
1.316 albertel 3278: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
1.230 foxr 3279: "while attempting put\n", $userinput);
3280: }
3281: } else {
3282: &Failure( $client, "refused\n", $userinput);
3283: }
3284:
3285: return 1;
3286: }
3287: ®ister_handler("put", \&put_user_profile_entry, 0, 1, 0);
3288:
1.283 albertel 3289: # Put a piece of new data in hash, returns error if entry already exists
3290: # Parameters:
3291: # $cmd - The command that got us here.
3292: # $tail - Tail of the command (remaining parameters).
3293: # $client - File descriptor connected to client.
3294: # Returns
3295: # 0 - Requested to exit, caller should shut down.
3296: # 1 - Continue processing.
3297: #
3298: sub newput_user_profile_entry {
3299: my ($cmd, $tail, $client) = @_;
3300:
3301: my $userinput = "$cmd:$tail";
3302:
3303: my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
3304: if ($namespace eq 'roles') {
3305: &Failure( $client, "refused\n", $userinput);
3306: return 1;
3307: }
3308:
3309: chomp($what);
3310:
3311: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3312: &GDBM_WRCREAT(),"N",$what);
3313: if(!$hashref) {
1.316 albertel 3314: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
1.283 albertel 3315: "while attempting put\n", $userinput);
3316: return 1;
3317: }
3318:
3319: my @pairs=split(/\&/,$what);
3320: foreach my $pair (@pairs) {
3321: my ($key,$value)=split(/=/,$pair);
3322: if (exists($hashref->{$key})) {
1.513 raeburn 3323: if (!&untie_user_hash($hashref)) {
3324: &logthis("error: ".($!+0)." untie (GDBM) failed ".
3325: "while attempting newput - early out as key exists");
3326: }
3327: &Failure($client, "key_exists: ".$key."\n",$userinput);
3328: return 1;
1.283 albertel 3329: }
3330: }
3331:
3332: foreach my $pair (@pairs) {
3333: my ($key,$value)=split(/=/,$pair);
3334: $hashref->{$key}=$value;
3335: }
3336:
1.311 albertel 3337: if (&untie_user_hash($hashref)) {
1.283 albertel 3338: &Reply( $client, "ok\n", $userinput);
3339: } else {
3340: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
3341: "while attempting put\n",
3342: $userinput);
3343: }
3344: return 1;
3345: }
3346: ®ister_handler("newput", \&newput_user_profile_entry, 0, 1, 0);
3347:
1.230 foxr 3348: #
3349: # Increment a profile entry in the user history file.
3350: # The history contains keyword value pairs. In this case,
3351: # The value itself is a pair of numbers. The first, the current value
3352: # the second an increment that this function applies to the current
3353: # value.
3354: #
3355: # Parameters:
3356: # $cmd - The command that got us here.
3357: # $tail - Tail of the command (remaining parameters).
3358: # $client - File descriptor connected to client.
3359: # Returns
3360: # 0 - Requested to exit, caller should shut down.
3361: # 1 - Continue processing.
3362: #
3363: sub increment_user_value_handler {
3364: my ($cmd, $tail, $client) = @_;
3365:
3366: my $userinput = "$cmd:$tail";
3367:
3368: my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
3369: if ($namespace ne 'roles') {
3370: chomp($what);
3371: my $hashref = &tie_user_hash($udom, $uname,
3372: $namespace, &GDBM_WRCREAT(),
3373: "P",$what);
3374: if ($hashref) {
3375: my @pairs=split(/\&/,$what);
3376: foreach my $pair (@pairs) {
3377: my ($key,$value)=split(/=/,$pair);
1.284 raeburn 3378: $value = &unescape($value);
1.230 foxr 3379: # We could check that we have a number...
3380: if (! defined($value) || $value eq '') {
3381: $value = 1;
3382: }
3383: $hashref->{$key}+=$value;
1.284 raeburn 3384: if ($namespace eq 'nohist_resourcetracker') {
3385: if ($hashref->{$key} < 0) {
3386: $hashref->{$key} = 0;
3387: }
3388: }
1.230 foxr 3389: }
1.311 albertel 3390: if (&untie_user_hash($hashref)) {
1.230 foxr 3391: &Reply( $client, "ok\n", $userinput);
3392: } else {
3393: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
3394: "while attempting inc\n", $userinput);
3395: }
3396: } else {
3397: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
3398: "while attempting inc\n", $userinput);
3399: }
3400: } else {
3401: &Failure($client, "refused\n", $userinput);
3402: }
3403:
3404: return 1;
3405: }
3406: ®ister_handler("inc", \&increment_user_value_handler, 0, 1, 0);
3407:
3408: #
3409: # Put a new role for a user. Roles are LonCAPA's packaging of permissions.
3410: # Each 'role' a user has implies a set of permissions. Adding a new role
3411: # for a person grants the permissions packaged with that role
3412: # to that user when the role is selected.
3413: #
3414: # Parameters:
3415: # $cmd - The command string (rolesput).
3416: # $tail - The remainder of the request line. For rolesput this
3417: # consists of a colon separated list that contains:
3418: # The domain and user that is granting the role (logged).
3419: # The domain and user that is getting the role.
3420: # The roles being granted as a set of & separated pairs.
3421: # each pair a key value pair.
3422: # $client - File descriptor connected to the client.
3423: # Returns:
3424: # 0 - If the daemon should exit
3425: # 1 - To continue processing.
3426: #
3427: #
3428: sub roles_put_handler {
3429: my ($cmd, $tail, $client) = @_;
3430:
3431: my $userinput = "$cmd:$tail";
3432:
3433: my ( $exedom, $exeuser, $udom, $uname, $what) = split(/:/,$tail);
3434:
3435:
3436: my $namespace='roles';
3437: chomp($what);
3438: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3439: &GDBM_WRCREAT(), "P",
3440: "$exedom:$exeuser:$what");
3441: #
3442: # Log the attempt to set a role. The {}'s here ensure that the file
3443: # handle is open for the minimal amount of time. Since the flush
3444: # is done on close this improves the chances the log will be an un-
3445: # corrupted ordered thing.
3446: if ($hashref) {
1.261 foxr 3447: my $pass_entry = &get_auth_type($udom, $uname);
3448: my ($auth_type,$pwd) = split(/:/, $pass_entry);
3449: $auth_type = $auth_type.":";
1.230 foxr 3450: my @pairs=split(/\&/,$what);
3451: foreach my $pair (@pairs) {
3452: my ($key,$value)=split(/=/,$pair);
3453: &manage_permissions($key, $udom, $uname,
1.260 foxr 3454: $auth_type);
1.230 foxr 3455: $hashref->{$key}=$value;
3456: }
1.311 albertel 3457: if (&untie_user_hash($hashref)) {
1.230 foxr 3458: &Reply($client, "ok\n", $userinput);
3459: } else {
3460: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
3461: "while attempting rolesput\n", $userinput);
3462: }
3463: } else {
3464: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3465: "while attempting rolesput\n", $userinput);
3466: }
3467: return 1;
3468: }
3469: ®ister_handler("rolesput", \&roles_put_handler, 1,1,0); # Encoded client only.
3470:
3471: #
1.231 foxr 3472: # Deletes (removes) a role for a user. This is equivalent to removing
3473: # a permissions package associated with the role from the user's profile.
3474: #
3475: # Parameters:
3476: # $cmd - The command (rolesdel)
3477: # $tail - The remainder of the request line. This consists
3478: # of:
3479: # The domain and user requesting the change (logged)
3480: # The domain and user being changed.
3481: # The roles being revoked. These are shipped to us
3482: # as a bunch of & separated role name keywords.
3483: # $client - The file handle open on the client.
3484: # Returns:
3485: # 1 - Continue processing
3486: # 0 - Exit.
3487: #
3488: sub roles_delete_handler {
3489: my ($cmd, $tail, $client) = @_;
3490:
3491: my $userinput = "$cmd:$tail";
3492:
3493: my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
3494: &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
3495: "what = ".$what);
3496: my $namespace='roles';
3497: chomp($what);
3498: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3499: &GDBM_WRCREAT(), "D",
3500: "$exedom:$exeuser:$what");
3501:
3502: if ($hashref) {
3503: my @rolekeys=split(/\&/,$what);
3504:
3505: foreach my $key (@rolekeys) {
3506: delete $hashref->{$key};
3507: }
1.315 albertel 3508: if (&untie_user_hash($hashref)) {
1.231 foxr 3509: &Reply($client, "ok\n", $userinput);
3510: } else {
3511: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
3512: "while attempting rolesdel\n", $userinput);
3513: }
3514: } else {
3515: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3516: "while attempting rolesdel\n", $userinput);
3517: }
3518:
3519: return 1;
3520: }
3521: ®ister_handler("rolesdel", \&roles_delete_handler, 1,1, 0); # Encoded client only
3522:
3523: # Unencrypted get from a user's profile database. See
3524: # GetProfileEntryEncrypted for a version that does end-to-end encryption.
3525: # This function retrieves a keyed item from a specific named database in the
3526: # user's directory.
3527: #
3528: # Parameters:
3529: # $cmd - Command request keyword (get).
3530: # $tail - Tail of the command. This is a colon separated list
3531: # consisting of the domain and username that uniquely
3532: # identifies the profile,
3533: # The 'namespace' which selects the gdbm file to
3534: # do the lookup in,
3535: # & separated list of keys to lookup. Note that
3536: # the values are returned as an & separated list too.
3537: # $client - File descriptor open on the client.
3538: # Returns:
3539: # 1 - Continue processing.
3540: # 0 - Exit.
3541: #
3542: sub get_profile_entry {
3543: my ($cmd, $tail, $client) = @_;
3544:
3545: my $userinput= "$cmd:$tail";
3546:
3547: my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
3548: chomp($what);
1.255 foxr 3549:
1.390 raeburn 3550:
1.255 foxr 3551: my $replystring = read_profile($udom, $uname, $namespace, $what);
3552: my ($first) = split(/:/,$replystring);
3553: if($first ne "error") {
1.387 albertel 3554: &Reply($client, \$replystring, $userinput);
1.231 foxr 3555: } else {
1.255 foxr 3556: &Failure($client, $replystring." while attempting get\n", $userinput);
1.231 foxr 3557: }
3558: return 1;
1.255 foxr 3559:
3560:
1.231 foxr 3561: }
3562: ®ister_handler("get", \&get_profile_entry, 0,1,0);
3563:
3564: #
3565: # Process the encrypted get request. Note that the request is sent
3566: # in clear, but the reply is encrypted. This is a small covert channel:
3567: # information about the sensitive keys is given to the snooper. Just not
3568: # information about the values of the sensitive key. Hmm if I wanted to
3569: # know these I'd snoop for the egets. Get the profile item names from them
3570: # and then issue a get for them since there's no enforcement of the
3571: # requirement of an encrypted get for particular profile items. If I
3572: # were re-doing this, I'd force the request to be encrypted as well as the
3573: # reply. I'd also just enforce encrypted transactions for all gets since
3574: # that would prevent any covert channel snooping.
3575: #
3576: # Parameters:
3577: # $cmd - Command keyword of request (eget).
1.536 raeburn 3578: # $tail - Tail of the command. See GetProfileEntry
3579: # for more information about this.
1.231 foxr 3580: # $client - File open on the client.
3581: # Returns:
3582: # 1 - Continue processing
3583: # 0 - server should exit.
3584: sub get_profile_entry_encrypted {
3585: my ($cmd, $tail, $client) = @_;
3586:
3587: my $userinput = "$cmd:$tail";
3588:
1.339 albertel 3589: my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
1.231 foxr 3590: chomp($what);
1.255 foxr 3591: my $qresult = read_profile($udom, $uname, $namespace, $what);
3592: my ($first) = split(/:/, $qresult);
3593: if($first ne "error") {
3594:
3595: if ($cipher) {
3596: my $cmdlength=length($qresult);
3597: $qresult.=" ";
3598: my $encqresult='';
3599: for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
3600: $encqresult.= unpack("H16",
3601: $cipher->encrypt(substr($qresult,
3602: $encidx,
3603: 8)));
3604: }
3605: &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
3606: } else {
1.231 foxr 3607: &Failure( $client, "error:no_key\n", $userinput);
3608: }
3609: } else {
1.255 foxr 3610: &Failure($client, "$qresult while attempting eget\n", $userinput);
3611:
1.231 foxr 3612: }
3613:
3614: return 1;
3615: }
1.255 foxr 3616: ®ister_handler("eget", \&get_profile_entry_encrypted, 0, 1, 0);
1.263 albertel 3617:
1.231 foxr 3618: #
3619: # Deletes a key in a user profile database.
3620: #
3621: # Parameters:
3622: # $cmd - Command keyword (del).
3623: # $tail - Command tail. IN this case a colon
3624: # separated list containing:
3625: # The domain and user that identifies uniquely
3626: # the identity of the user.
3627: # The profile namespace (name of the profile
3628: # database file).
3629: # & separated list of keywords to delete.
3630: # $client - File open on client socket.
3631: # Returns:
3632: # 1 - Continue processing
3633: # 0 - Exit server.
3634: #
3635: #
3636: sub delete_profile_entry {
3637: my ($cmd, $tail, $client) = @_;
3638:
3639: my $userinput = "cmd:$tail";
3640:
3641: my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
3642: chomp($what);
3643: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3644: &GDBM_WRCREAT(),
3645: "D",$what);
3646: if ($hashref) {
3647: my @keys=split(/\&/,$what);
3648: foreach my $key (@keys) {
3649: delete($hashref->{$key});
3650: }
1.315 albertel 3651: if (&untie_user_hash($hashref)) {
1.231 foxr 3652: &Reply($client, "ok\n", $userinput);
3653: } else {
3654: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3655: "while attempting del\n", $userinput);
3656: }
3657: } else {
3658: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3659: "while attempting del\n", $userinput);
3660: }
3661: return 1;
3662: }
3663: ®ister_handler("del", \&delete_profile_entry, 0, 1, 0);
1.263 albertel 3664:
1.231 foxr 3665: #
3666: # List the set of keys that are defined in a profile database file.
3667: # A successful reply from this will contain an & separated list of
3668: # the keys.
3669: # Parameters:
3670: # $cmd - Command request (keys).
3671: # $tail - Remainder of the request, a colon separated
3672: # list containing domain/user that identifies the
3673: # user being queried, and the database namespace
3674: # (database filename essentially).
3675: # $client - File open on the client.
3676: # Returns:
3677: # 1 - Continue processing.
3678: # 0 - Exit the server.
3679: #
3680: sub get_profile_keys {
3681: my ($cmd, $tail, $client) = @_;
3682:
3683: my $userinput = "$cmd:$tail";
3684:
3685: my ($udom,$uname,$namespace)=split(/:/,$tail);
3686: my $qresult='';
3687: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3688: &GDBM_READER());
3689: if ($hashref) {
3690: foreach my $key (keys %$hashref) {
3691: $qresult.="$key&";
3692: }
1.315 albertel 3693: if (&untie_user_hash($hashref)) {
1.231 foxr 3694: $qresult=~s/\&$//;
1.387 albertel 3695: &Reply($client, \$qresult, $userinput);
1.231 foxr 3696: } else {
3697: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3698: "while attempting keys\n", $userinput);
3699: }
3700: } else {
3701: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3702: "while attempting keys\n", $userinput);
3703: }
3704:
3705: return 1;
3706: }
3707: ®ister_handler("keys", \&get_profile_keys, 0, 1, 0);
3708:
3709: #
3710: # Dump the contents of a user profile database.
3711: # Note that this constitutes a very large covert channel too since
3712: # the dump will return sensitive information that is not encrypted.
3713: # The naive security assumption is that the session negotiation ensures
3714: # our client is trusted and I don't believe that's assured at present.
3715: # Sure want badly to go to ssl or tls. Of course if my peer isn't really
3716: # a LonCAPA node they could have negotiated an encryption key too so >sigh<.
3717: #
3718: # Parameters:
3719: # $cmd - The command request keyword (currentdump).
3720: # $tail - Remainder of the request, consisting of a colon
3721: # separated list that has the domain/username and
3722: # the namespace to dump (database file).
3723: # $client - file open on the remote client.
3724: # Returns:
3725: # 1 - Continue processing.
3726: # 0 - Exit the server.
3727: #
3728: sub dump_profile_database {
3729: my ($cmd, $tail, $client) = @_;
3730:
1.494 droeschl 3731: my $res = LONCAPA::Lond::dump_profile_database($tail);
3732:
3733: if ($res =~ /^error:/) {
3734: Failure($client, \$res, "$cmd:$tail");
3735: } else {
3736: Reply($client, \$res, "$cmd:$tail");
3737: }
3738:
3739: return 1;
3740:
3741: #TODO remove
1.231 foxr 3742: my $userinput = "$cmd:$tail";
3743:
3744: my ($udom,$uname,$namespace) = split(/:/,$tail);
3745: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3746: &GDBM_READER());
3747: if ($hashref) {
3748: # Structure of %data:
3749: # $data{$symb}->{$parameter}=$value;
3750: # $data{$symb}->{'v.'.$parameter}=$version;
3751: # since $parameter will be unescaped, we do not
3752: # have to worry about silly parameter names...
3753:
3754: my $qresult='';
3755: my %data = (); # A hash of anonymous hashes..
3756: while (my ($key,$value) = each(%$hashref)) {
3757: my ($v,$symb,$param) = split(/:/,$key);
3758: next if ($v eq 'version' || $symb eq 'keys');
3759: next if (exists($data{$symb}) &&
3760: exists($data{$symb}->{$param}) &&
3761: $data{$symb}->{'v.'.$param} > $v);
3762: $data{$symb}->{$param}=$value;
3763: $data{$symb}->{'v.'.$param}=$v;
3764: }
1.311 albertel 3765: if (&untie_user_hash($hashref)) {
1.231 foxr 3766: while (my ($symb,$param_hash) = each(%data)) {
3767: while(my ($param,$value) = each (%$param_hash)){
3768: next if ($param =~ /^v\./); # Ignore versions...
3769: #
3770: # Just dump the symb=value pairs separated by &
3771: #
3772: $qresult.=$symb.':'.$param.'='.$value.'&';
3773: }
3774: }
3775: chop($qresult);
1.387 albertel 3776: &Reply($client , \$qresult, $userinput);
1.231 foxr 3777: } else {
3778: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
3779: "while attempting currentdump\n", $userinput);
3780: }
3781: } else {
3782: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
3783: "while attempting currentdump\n", $userinput);
3784: }
3785:
3786: return 1;
3787: }
3788: ®ister_handler("currentdump", \&dump_profile_database, 0, 1, 0);
3789:
3790: #
3791: # Dump a profile database with an optional regular expression
3792: # to match against the keys. In this dump, no effort is made
3793: # to separate symb from version information. Presumably the
3794: # databases that are dumped by this command are of a different
3795: # structure. Need to look at this and improve the documentation of
3796: # both this and the currentdump handler.
3797: # Parameters:
3798: # $cmd - The command keyword.
3799: # $tail - All of the characters after the $cmd:
3800: # These are expected to be a colon
3801: # separated list containing:
3802: # domain/user - identifying the user.
3803: # namespace - identifying the database.
3804: # regexp - optional regular expression
3805: # that is matched against
3806: # database keywords to do
3807: # selective dumps.
1.488 raeburn 3808: # range - optional range of entries
3809: # e.g., 10-20 would return the
3810: # 10th to 19th items, etc.
1.231 foxr 3811: # $client - Channel open on the client.
3812: # Returns:
3813: # 1 - Continue processing.
3814: # Side effects:
3815: # response is written to $client.
3816: #
3817: sub dump_with_regexp {
3818: my ($cmd, $tail, $client) = @_;
3819:
1.494 droeschl 3820: my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion);
1.490 droeschl 3821:
3822: if ($res =~ /^error:/) {
3823: Failure($client, \$res, "$cmd:$tail");
3824: } else {
3825: Reply($client, \$res, "$cmd:$tail");
3826: }
1.231 foxr 3827:
3828: return 1;
3829: }
3830: ®ister_handler("dump", \&dump_with_regexp, 0, 1, 0);
3831:
3832: # Store a set of key=value pairs associated with a versioned name.
3833: #
3834: # Parameters:
3835: # $cmd - Request command keyword.
3836: # $tail - Tail of the request. This is a colon
3837: # separated list containing:
3838: # domain/user - User and authentication domain.
3839: # namespace - Name of the database being modified
3840: # rid - Resource keyword to modify.
3841: # what - new value associated with rid.
1.512 raeburn 3842: # laststore - (optional) version=timestamp
3843: # for most recent transaction for rid
3844: # in namespace, when cstore was called
1.231 foxr 3845: #
3846: # $client - Socket open on the client.
3847: #
3848: #
3849: # Returns:
3850: # 1 (keep on processing).
3851: # Side-Effects:
3852: # Writes to the client
1.512 raeburn 3853: # Successful storage will cause either 'ok', or, if $laststore was included
3854: # in the tail of the request, and the version number for the last transaction
3855: # is larger than the version in $laststore, delay:$numtrans , where $numtrans
3856: # is the number of store evevnts recorded for rid in namespace since
3857: # lonnet::store() was called by the client.
3858: #
1.231 foxr 3859: sub store_handler {
3860: my ($cmd, $tail, $client) = @_;
3861:
3862: my $userinput = "$cmd:$tail";
1.512 raeburn 3863: chomp($tail);
3864: my ($udom,$uname,$namespace,$rid,$what,$laststore) =split(/:/,$tail);
1.231 foxr 3865: if ($namespace ne 'roles') {
3866:
3867: my @pairs=split(/\&/,$what);
3868: my $hashref = &tie_user_hash($udom, $uname, $namespace,
1.268 albertel 3869: &GDBM_WRCREAT(), "S",
1.231 foxr 3870: "$rid:$what");
3871: if ($hashref) {
3872: my $now = time;
1.512 raeburn 3873: my $numtrans;
3874: if ($laststore) {
3875: my ($previousversion,$previoustime) = split(/\=/,$laststore);
3876: my ($lastversion,$lasttime) = (0,0);
3877: $lastversion = $hashref->{"version:$rid"};
3878: if ($lastversion) {
3879: $lasttime = $hashref->{"$lastversion:$rid:timestamp"};
3880: }
3881: if (($previousversion) && ($previousversion !~ /\D/)) {
3882: if (($lastversion > $previousversion) && ($lasttime >= $previoustime)) {
3883: $numtrans = $lastversion - $previousversion;
3884: }
3885: } elsif ($lastversion) {
3886: $numtrans = $lastversion;
3887: }
3888: if ($numtrans) {
3889: $numtrans =~ s/D//g;
3890: }
3891: }
1.231 foxr 3892: $hashref->{"version:$rid"}++;
3893: my $version=$hashref->{"version:$rid"};
3894: my $allkeys='';
3895: foreach my $pair (@pairs) {
3896: my ($key,$value)=split(/=/,$pair);
3897: $allkeys.=$key.':';
3898: $hashref->{"$version:$rid:$key"}=$value;
3899: }
3900: $hashref->{"$version:$rid:timestamp"}=$now;
3901: $allkeys.='timestamp';
3902: $hashref->{"$version:keys:$rid"}=$allkeys;
1.311 albertel 3903: if (&untie_user_hash($hashref)) {
1.512 raeburn 3904: my $msg = 'ok';
3905: if ($numtrans) {
3906: $msg = 'delay:'.$numtrans;
3907: }
3908: &Reply($client, "$msg\n", $userinput);
1.231 foxr 3909: } else {
3910: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3911: "while attempting store\n", $userinput);
3912: }
3913: } else {
3914: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3915: "while attempting store\n", $userinput);
3916: }
3917: } else {
3918: &Failure($client, "refused\n", $userinput);
3919: }
3920:
3921: return 1;
3922: }
3923: ®ister_handler("store", \&store_handler, 0, 1, 0);
1.263 albertel 3924:
1.323 albertel 3925: # Modify a set of key=value pairs associated with a versioned name.
3926: #
3927: # Parameters:
3928: # $cmd - Request command keyword.
3929: # $tail - Tail of the request. This is a colon
3930: # separated list containing:
3931: # domain/user - User and authentication domain.
3932: # namespace - Name of the database being modified
3933: # rid - Resource keyword to modify.
3934: # v - Version item to modify
3935: # what - new value associated with rid.
3936: #
3937: # $client - Socket open on the client.
3938: #
3939: #
3940: # Returns:
3941: # 1 (keep on processing).
3942: # Side-Effects:
3943: # Writes to the client
3944: sub putstore_handler {
3945: my ($cmd, $tail, $client) = @_;
3946:
3947: my $userinput = "$cmd:$tail";
3948:
3949: my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail);
3950: if ($namespace ne 'roles') {
3951:
3952: chomp($what);
3953: my $hashref = &tie_user_hash($udom, $uname, $namespace,
3954: &GDBM_WRCREAT(), "M",
3955: "$rid:$v:$what");
3956: if ($hashref) {
3957: my $now = time;
3958: my %data = &hash_extract($what);
3959: my @allkeys;
3960: while (my($key,$value) = each(%data)) {
3961: push(@allkeys,$key);
3962: $hashref->{"$v:$rid:$key"} = $value;
3963: }
3964: my $allkeys = join(':',@allkeys);
3965: $hashref->{"$v:keys:$rid"}=$allkeys;
3966:
3967: if (&untie_user_hash($hashref)) {
3968: &Reply($client, "ok\n", $userinput);
3969: } else {
3970: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
3971: "while attempting store\n", $userinput);
3972: }
3973: } else {
3974: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
3975: "while attempting store\n", $userinput);
3976: }
3977: } else {
3978: &Failure($client, "refused\n", $userinput);
3979: }
3980:
3981: return 1;
3982: }
3983: ®ister_handler("putstore", \&putstore_handler, 0, 1, 0);
3984:
3985: sub hash_extract {
3986: my ($str)=@_;
3987: my %hash;
3988: foreach my $pair (split(/\&/,$str)) {
3989: my ($key,$value)=split(/=/,$pair);
3990: $hash{$key}=$value;
3991: }
3992: return (%hash);
3993: }
3994: sub hash_to_str {
3995: my ($hash_ref)=@_;
3996: my $str;
3997: foreach my $key (keys(%$hash_ref)) {
3998: $str.=$key.'='.$hash_ref->{$key}.'&';
3999: }
4000: $str=~s/\&$//;
4001: return $str;
4002: }
4003:
1.231 foxr 4004: #
4005: # Dump out all versions of a resource that has key=value pairs associated
4006: # with it for each version. These resources are built up via the store
4007: # command.
4008: #
4009: # Parameters:
4010: # $cmd - Command keyword.
4011: # $tail - Remainder of the request which consists of:
4012: # domain/user - User and auth. domain.
4013: # namespace - name of resource database.
4014: # rid - Resource id.
4015: # $client - socket open on the client.
4016: #
4017: # Returns:
4018: # 1 indicating the caller should not yet exit.
4019: # Side-effects:
4020: # Writes a reply to the client.
4021: # The reply is a string of the following shape:
4022: # version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2...
4023: # Where the 1 above represents version 1.
4024: # this continues for all pairs of keys in all versions.
4025: #
4026: #
4027: #
4028: #
4029: sub restore_handler {
4030: my ($cmd, $tail, $client) = @_;
4031:
4032: my $userinput = "$cmd:$tail"; # Only used for logging purposes.
1.351 banghart 4033: my ($udom,$uname,$namespace,$rid) = split(/:/,$tail);
1.352 albertel 4034: $namespace=~s/\//\_/g;
1.350 albertel 4035: $namespace = &LONCAPA::clean_username($namespace);
1.349 albertel 4036:
1.231 foxr 4037: chomp($rid);
4038: my $qresult='';
1.309 albertel 4039: my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
4040: if ($hashref) {
4041: my $version=$hashref->{"version:$rid"};
1.231 foxr 4042: $qresult.="version=$version&";
4043: my $scope;
4044: for ($scope=1;$scope<=$version;$scope++) {
1.309 albertel 4045: my $vkeys=$hashref->{"$scope:keys:$rid"};
1.231 foxr 4046: my @keys=split(/:/,$vkeys);
4047: my $key;
4048: $qresult.="$scope:keys=$vkeys&";
4049: foreach $key (@keys) {
1.309 albertel 4050: $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
1.231 foxr 4051: }
4052: }
1.311 albertel 4053: if (&untie_user_hash($hashref)) {
1.231 foxr 4054: $qresult=~s/\&$//;
1.387 albertel 4055: &Reply( $client, \$qresult, $userinput);
1.231 foxr 4056: } else {
4057: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4058: "while attempting restore\n", $userinput);
4059: }
4060: } else {
4061: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
4062: "while attempting restore\n", $userinput);
4063: }
4064:
4065: return 1;
4066:
4067:
4068: }
4069: ®ister_handler("restore", \&restore_handler, 0,1,0);
1.234 foxr 4070:
4071: #
1.324 raeburn 4072: # Add a chat message to a synchronous discussion board.
1.234 foxr 4073: #
4074: # Parameters:
4075: # $cmd - Request keyword.
4076: # $tail - Tail of the command. A colon separated list
4077: # containing:
4078: # cdom - Domain on which the chat board lives
1.324 raeburn 4079: # cnum - Course containing the chat board.
4080: # newpost - Body of the posting.
4081: # group - Optional group, if chat board is only
4082: # accessible in a group within the course
1.234 foxr 4083: # $client - Socket open on the client.
4084: # Returns:
4085: # 1 - Indicating caller should keep on processing.
4086: #
4087: # Side-effects:
4088: # writes a reply to the client.
4089: #
4090: #
4091: sub send_chat_handler {
4092: my ($cmd, $tail, $client) = @_;
4093:
4094:
4095: my $userinput = "$cmd:$tail";
4096:
1.324 raeburn 4097: my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail);
4098: &chat_add($cdom,$cnum,$newpost,$group);
1.234 foxr 4099: &Reply($client, "ok\n", $userinput);
4100:
4101: return 1;
4102: }
4103: ®ister_handler("chatsend", \&send_chat_handler, 0, 1, 0);
1.263 albertel 4104:
1.234 foxr 4105: #
1.324 raeburn 4106: # Retrieve the set of chat messages from a discussion board.
1.234 foxr 4107: #
4108: # Parameters:
4109: # $cmd - Command keyword that initiated the request.
4110: # $tail - Remainder of the request after the command
4111: # keyword. In this case a colon separated list of
4112: # chat domain - Which discussion board.
4113: # chat id - Discussion thread(?)
4114: # domain/user - Authentication domain and username
4115: # of the requesting person.
1.324 raeburn 4116: # group - Optional course group containing
4117: # the board.
1.234 foxr 4118: # $client - Socket open on the client program.
4119: # Returns:
4120: # 1 - continue processing
4121: # Side effects:
4122: # Response is written to the client.
4123: #
4124: sub retrieve_chat_handler {
4125: my ($cmd, $tail, $client) = @_;
4126:
4127:
4128: my $userinput = "$cmd:$tail";
4129:
1.324 raeburn 4130: my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail);
1.234 foxr 4131: my $reply='';
1.324 raeburn 4132: foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) {
1.234 foxr 4133: $reply.=&escape($_).':';
4134: }
4135: $reply=~s/\:$//;
1.387 albertel 4136: &Reply($client, \$reply, $userinput);
1.234 foxr 4137:
4138:
4139: return 1;
4140: }
4141: ®ister_handler("chatretr", \&retrieve_chat_handler, 0, 1, 0);
4142:
4143: #
4144: # Initiate a query of an sql database. SQL query repsonses get put in
4145: # a file for later retrieval. This prevents sql query results from
4146: # bottlenecking the system. Note that with loncnew, perhaps this is
4147: # less of an issue since multiple outstanding requests can be concurrently
4148: # serviced.
4149: #
4150: # Parameters:
1.535 raeburn 4151: # $cmd - Command keyword that initiated the request.
1.234 foxr 4152: # $tail - Remainder of the command after the keyword.
4153: # For this function, this consists of a query and
4154: # 3 arguments that are self-documentingly labelled
4155: # in the original arg1, arg2, arg3.
4156: # $client - Socket open on the client.
4157: # Return:
4158: # 1 - Indicating processing should continue.
4159: # Side-effects:
4160: # a reply is written to $client.
4161: #
4162: sub send_query_handler {
4163: my ($cmd, $tail, $client) = @_;
4164:
4165: my $userinput = "$cmd:$tail";
4166:
4167: my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);
4168: $query=~s/\n*$//g;
1.534 raeburn 4169: if (($query eq 'usersearch') || ($query eq 'instdirsearch')) {
4170: my $usersearchconf = &get_usersearch_config($currentdomainid,'directorysrch');
4171: my $earlyout;
4172: if (ref($usersearchconf) eq 'HASH') {
4173: if ($currentdomainid eq $clienthomedom) {
4174: if ($query eq 'usersearch') {
4175: if ($usersearchconf->{'lcavailable'} eq '0') {
4176: $earlyout = 1;
4177: }
4178: } else {
4179: if ($usersearchconf->{'available'} eq '0') {
4180: $earlyout = 1;
4181: }
4182: }
4183: } else {
4184: if ($query eq 'usersearch') {
4185: if ($usersearchconf->{'lclocalonly'}) {
4186: $earlyout = 1;
4187: }
4188: } else {
4189: if ($usersearchconf->{'localonly'}) {
4190: $earlyout = 1;
4191: }
4192: }
4193: }
4194: }
4195: if ($earlyout) {
4196: &Reply($client, "query_not_authorized\n");
4197: return 1;
4198: }
4199: }
1.234 foxr 4200: &Reply($client, "". &sql_reply("$clientname\&$query".
4201: "\&$arg1"."\&$arg2"."\&$arg3")."\n",
4202: $userinput);
4203:
4204: return 1;
4205: }
4206: ®ister_handler("querysend", \&send_query_handler, 0, 1, 0);
4207:
4208: #
4209: # Add a reply to an sql query. SQL queries are done asyncrhonously.
4210: # The query is submitted via a "querysend" transaction.
4211: # There it is passed on to the lonsql daemon, queued and issued to
4212: # mysql.
4213: # This transaction is invoked when the sql transaction is complete
4214: # it stores the query results in flie and indicates query completion.
4215: # presumably local software then fetches this response... I'm guessing
4216: # the sequence is: lonc does a querysend, we ask lonsql to do it.
4217: # lonsql on completion of the query interacts with the lond of our
4218: # client to do a query reply storing two files:
4219: # - id - The results of the query.
4220: # - id.end - Indicating the transaction completed.
4221: # NOTE: id is a unique id assigned to the query and querysend time.
4222: # Parameters:
4223: # $cmd - Command keyword that initiated this request.
4224: # $tail - Remainder of the tail. In this case that's a colon
4225: # separated list containing the query Id and the
4226: # results of the query.
4227: # $client - Socket open on the client.
4228: # Return:
4229: # 1 - Indicating that we should continue processing.
4230: # Side effects:
4231: # ok written to the client.
4232: #
4233: sub reply_query_handler {
4234: my ($cmd, $tail, $client) = @_;
4235:
4236:
4237: my $userinput = "$cmd:$tail";
4238:
1.339 albertel 4239: my ($id,$reply)=split(/:/,$tail);
1.234 foxr 4240: my $store;
4241: my $execdir=$perlvar{'lonDaemons'};
4242: if ($store=IO::File->new(">$execdir/tmp/$id")) {
4243: $reply=~s/\&/\n/g;
4244: print $store $reply;
4245: close $store;
4246: my $store2=IO::File->new(">$execdir/tmp/$id.end");
4247: print $store2 "done\n";
4248: close $store2;
4249: &Reply($client, "ok\n", $userinput);
4250: } else {
4251: &Failure($client, "error: ".($!+0)
4252: ." IO::File->new Failed ".
4253: "while attempting queryreply\n", $userinput);
4254: }
4255:
4256:
4257: return 1;
4258: }
4259: ®ister_handler("queryreply", \&reply_query_handler, 0, 1, 0);
4260:
4261: #
4262: # Process the courseidput request. Not quite sure what this means
4263: # at the system level sense. It appears a gdbm file in the
4264: # /home/httpd/lonUsers/$domain/nohist_courseids is tied and
4265: # a set of entries made in that database.
4266: #
4267: # Parameters:
4268: # $cmd - The command keyword that initiated this request.
4269: # $tail - Tail of the command. In this case consists of a colon
4270: # separated list contaning the domain to apply this to and
4271: # an ampersand separated list of keyword=value pairs.
1.272 raeburn 4272: # Each value is a colon separated list that includes:
4273: # description, institutional code and course owner.
4274: # For backward compatibility with versions included
4275: # in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional
4276: # code and/or course owner are preserved from the existing
4277: # record when writing a new record in response to 1.1 or
4278: # 1.2 implementations of lonnet::flushcourselogs().
4279: #
1.234 foxr 4280: # $client - Socket open on the client.
4281: # Returns:
4282: # 1 - indicating that processing should continue
4283: #
4284: # Side effects:
4285: # reply is written to the client.
4286: #
4287: sub put_course_id_handler {
4288: my ($cmd, $tail, $client) = @_;
4289:
4290:
4291: my $userinput = "$cmd:$tail";
4292:
1.266 raeburn 4293: my ($udom, $what) = split(/:/, $tail,2);
1.234 foxr 4294: chomp($what);
4295: my $now=time;
4296: my @pairs=split(/\&/,$what);
4297:
4298: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
4299: if ($hashref) {
4300: foreach my $pair (@pairs) {
1.271 raeburn 4301: my ($key,$courseinfo) = split(/=/,$pair,2);
4302: $courseinfo =~ s/=/:/g;
1.384 raeburn 4303: if (defined($hashref->{$key})) {
4304: my $value = &Apache::lonnet::thaw_unescape($hashref->{$key});
4305: if (ref($value) eq 'HASH') {
4306: my @items = ('description','inst_code','owner','type');
4307: my @new_items = split(/:/,$courseinfo,-1);
4308: my %storehash;
4309: for (my $i=0; $i<@new_items; $i++) {
1.391 raeburn 4310: $storehash{$items[$i]} = &unescape($new_items[$i]);
1.384 raeburn 4311: }
4312: $hashref->{$key} =
4313: &Apache::lonnet::freeze_escape(\%storehash);
4314: my $unesc_key = &unescape($key);
4315: $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
4316: next;
1.383 raeburn 4317: }
1.384 raeburn 4318: }
4319: my @current_items = split(/:/,$hashref->{$key},-1);
4320: shift(@current_items); # remove description
4321: pop(@current_items); # remove last access
4322: my $numcurrent = scalar(@current_items);
4323: if ($numcurrent > 3) {
4324: $numcurrent = 3;
4325: }
4326: my @new_items = split(/:/,$courseinfo,-1);
4327: my $numnew = scalar(@new_items);
4328: if ($numcurrent > 0) {
4329: if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2
4330: for (my $j=$numcurrent-$numnew; $j>=0; $j--) {
4331: $courseinfo .= ':'.$current_items[$numcurrent-$j-1];
1.333 raeburn 4332: }
1.272 raeburn 4333: }
4334: }
1.384 raeburn 4335: $hashref->{$key}=$courseinfo.':'.$now;
1.234 foxr 4336: }
1.311 albertel 4337: if (&untie_domain_hash($hashref)) {
1.253 foxr 4338: &Reply( $client, "ok\n", $userinput);
1.234 foxr 4339: } else {
1.253 foxr 4340: &Failure($client, "error: ".($!+0)
1.234 foxr 4341: ." untie(GDBM) Failed ".
4342: "while attempting courseidput\n", $userinput);
4343: }
4344: } else {
1.253 foxr 4345: &Failure($client, "error: ".($!+0)
1.234 foxr 4346: ." tie(GDBM) Failed ".
4347: "while attempting courseidput\n", $userinput);
4348: }
4349:
4350: return 1;
4351: }
4352: ®ister_handler("courseidput", \&put_course_id_handler, 0, 1, 0);
4353:
1.383 raeburn 4354: sub put_course_id_hash_handler {
4355: my ($cmd, $tail, $client) = @_;
4356: my $userinput = "$cmd:$tail";
1.384 raeburn 4357: my ($udom,$mode,$what) = split(/:/, $tail,3);
1.383 raeburn 4358: chomp($what);
4359: my $now=time;
4360: my @pairs=split(/\&/,$what);
1.384 raeburn 4361: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
1.383 raeburn 4362: if ($hashref) {
4363: foreach my $pair (@pairs) {
4364: my ($key,$value)=split(/=/,$pair);
1.384 raeburn 4365: my $unesc_key = &unescape($key);
4366: if ($mode ne 'timeonly') {
4367: if (!defined($hashref->{&escape('lasttime:'.$unesc_key)})) {
4368: my $curritems = &Apache::lonnet::thaw_unescape($key);
4369: if (ref($curritems) ne 'HASH') {
4370: my @current_items = split(/:/,$hashref->{$key},-1);
4371: my $lasttime = pop(@current_items);
4372: $hashref->{&escape('lasttime:'.$unesc_key)} = $lasttime;
4373: } else {
4374: $hashref->{&escape('lasttime:'.$unesc_key)} = '';
4375: }
4376: }
4377: $hashref->{$key} = $value;
4378: }
4379: if ($mode ne 'notime') {
4380: $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
4381: }
1.383 raeburn 4382: }
4383: if (&untie_domain_hash($hashref)) {
4384: &Reply($client, "ok\n", $userinput);
4385: } else {
4386: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4387: "while attempting courseidputhash\n", $userinput);
4388: }
4389: } else {
4390: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
4391: "while attempting courseidputhash\n", $userinput);
4392: }
4393: return 1;
4394: }
4395: ®ister_handler("courseidputhash", \&put_course_id_hash_handler, 0, 1, 0);
4396:
1.234 foxr 4397: # Retrieves the value of a course id resource keyword pattern
4398: # defined since a starting date. Both the starting date and the
4399: # keyword pattern are optional. If the starting date is not supplied it
4400: # is treated as the beginning of time. If the pattern is not found,
4401: # it is treatred as "." matching everything.
4402: #
4403: # Parameters:
4404: # $cmd - Command keyword that resulted in us being dispatched.
4405: # $tail - The remainder of the command that, in this case, consists
4406: # of a colon separated list of:
4407: # domain - The domain in which the course database is
4408: # defined.
4409: # since - Optional parameter describing the minimum
4410: # time of definition(?) of the resources that
4411: # will match the dump.
4412: # description - regular expression that is used to filter
4413: # the dump. Only keywords matching this regexp
4414: # will be used.
1.272 raeburn 4415: # institutional code - optional supplied code to filter
4416: # the dump. Only courses with an institutional code
4417: # that match the supplied code will be returned.
1.336 raeburn 4418: # owner - optional supplied username and domain of owner to
4419: # filter the dump. Only courses for which the course
4420: # owner matches the supplied username and/or domain
4421: # will be returned. Pre-2.2.0 legacy entries from
4422: # nohist_courseiddump will only contain usernames.
1.384 raeburn 4423: # type - optional parameter for selection
1.418 raeburn 4424: # regexp_ok - if 1 or -1 allow the supplied institutional code
4425: # filter to behave as a regular expression:
4426: # 1 will not exclude the course if the instcode matches the RE
4427: # -1 will exclude the course if the instcode matches the RE
1.384 raeburn 4428: # rtn_as_hash - whether to return the information available for
4429: # each matched item as a frozen hash of all
4430: # key, value pairs in the item's hash, or as a
4431: # colon-separated list of (in order) description,
4432: # institutional code, and course owner.
1.404 raeburn 4433: # selfenrollonly - filter by courses allowing self-enrollment
4434: # now or in the future (selfenrollonly = 1).
4435: # catfilter - filter by course category, assigned to a course
4436: # using manually defined categories (i.e., not
1.407 raeburn 4437: # self-cataloging based on on institutional code).
1.404 raeburn 4438: # showhidden - include course in results even if course
1.407 raeburn 4439: # was set to be excluded from course catalog (DC only).
1.404 raeburn 4440: # caller - if set to 'coursecatalog', courses set to be hidden
4441: # from course catalog will be excluded from results (unless
4442: # overridden by "showhidden".
1.427 raeburn 4443: # cloner - escaped username:domain of course cloner (if picking course to
1.419 raeburn 4444: # clone).
4445: # cc_clone_list - escaped comma separated list of courses for which
4446: # course cloner has active CC role (and so can clone
4447: # automatically).
1.427 raeburn 4448: # cloneonly - filter by courses for which cloner has rights to clone.
4449: # createdbefore - include courses for which creation date preceeded this date.
4450: # createdafter - include courses for which creation date followed this date.
4451: # creationcontext - include courses created in specified context
1.404 raeburn 4452: #
1.445 raeburn 4453: # domcloner - flag to indicate if user can create CCs in course's domain.
1.505 raeburn 4454: # If so, ability to clone course is automatic.
4455: # hasuniquecode - filter by courses for which a six character unique code has
4456: # been set.
1.445 raeburn 4457: #
1.234 foxr 4458: # $client - The socket open on the client.
4459: # Returns:
4460: # 1 - Continue processing.
4461: # Side Effects:
4462: # a reply is written to $client.
4463: sub dump_course_id_handler {
4464: my ($cmd, $tail, $client) = @_;
1.494 droeschl 4465:
4466: my $res = LONCAPA::Lond::dump_course_id_handler($tail);
4467: if ($res =~ /^error:/) {
4468: Failure($client, \$res, "$cmd:$tail");
4469: } else {
4470: Reply($client, \$res, "$cmd:$tail");
4471: }
4472:
4473: return 1;
4474:
4475: #TODO remove
1.234 foxr 4476: my $userinput = "$cmd:$tail";
4477:
1.333 raeburn 4478: my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
1.404 raeburn 4479: $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
1.427 raeburn 4480: $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
1.505 raeburn 4481: $creationcontext,$domcloner,$hasuniquecode) =split(/:/,$tail);
1.397 raeburn 4482: my $now = time;
1.419 raeburn 4483: my ($cloneruname,$clonerudom,%cc_clone);
1.234 foxr 4484: if (defined($description)) {
4485: $description=&unescape($description);
4486: } else {
4487: $description='.';
4488: }
1.266 raeburn 4489: if (defined($instcodefilter)) {
4490: $instcodefilter=&unescape($instcodefilter);
4491: } else {
4492: $instcodefilter='.';
4493: }
1.336 raeburn 4494: my ($ownerunamefilter,$ownerdomfilter);
1.266 raeburn 4495: if (defined($ownerfilter)) {
4496: $ownerfilter=&unescape($ownerfilter);
1.336 raeburn 4497: if ($ownerfilter ne '.' && defined($ownerfilter)) {
4498: if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
4499: $ownerunamefilter = $1;
4500: $ownerdomfilter = $2;
4501: } else {
4502: $ownerunamefilter = $ownerfilter;
4503: $ownerdomfilter = '';
4504: }
4505: }
1.266 raeburn 4506: } else {
4507: $ownerfilter='.';
4508: }
1.336 raeburn 4509:
1.282 raeburn 4510: if (defined($coursefilter)) {
4511: $coursefilter=&unescape($coursefilter);
4512: } else {
4513: $coursefilter='.';
4514: }
1.333 raeburn 4515: if (defined($typefilter)) {
4516: $typefilter=&unescape($typefilter);
4517: } else {
4518: $typefilter='.';
4519: }
1.344 raeburn 4520: if (defined($regexp_ok)) {
4521: $regexp_ok=&unescape($regexp_ok);
4522: }
1.401 raeburn 4523: if (defined($catfilter)) {
4524: $catfilter=&unescape($catfilter);
4525: }
1.419 raeburn 4526: if (defined($cloner)) {
4527: $cloner = &unescape($cloner);
4528: ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/);
4529: }
4530: if (defined($cc_clone_list)) {
4531: $cc_clone_list = &unescape($cc_clone_list);
4532: my @cc_cloners = split('&',$cc_clone_list);
4533: foreach my $cid (@cc_cloners) {
4534: my ($clonedom,$clonenum) = split(':',$cid);
4535: next if ($clonedom ne $udom);
4536: $cc_clone{$clonedom.'_'.$clonenum} = 1;
4537: }
4538: }
1.431 raeburn 4539: if ($createdbefore ne '') {
1.427 raeburn 4540: $createdbefore = &unescape($createdbefore);
4541: } else {
4542: $createdbefore = 0;
4543: }
1.431 raeburn 4544: if ($createdafter ne '') {
1.427 raeburn 4545: $createdafter = &unescape($createdafter);
4546: } else {
4547: $createdafter = 0;
4548: }
1.431 raeburn 4549: if ($creationcontext ne '') {
1.427 raeburn 4550: $creationcontext = &unescape($creationcontext);
4551: } else {
4552: $creationcontext = '.';
4553: }
1.505 raeburn 4554: unless ($hasuniquecode) {
4555: $hasuniquecode = '.';
4556: }
1.384 raeburn 4557: my $unpack = 1;
1.485 raeburn 4558: if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' &&
1.384 raeburn 4559: $typefilter eq '.') {
4560: $unpack = 0;
4561: }
4562: if (!defined($since)) { $since=0; }
1.234 foxr 4563: my $qresult='';
4564: my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
4565: if ($hashref) {
1.384 raeburn 4566: while (my ($key,$value) = each(%$hashref)) {
1.397 raeburn 4567: my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
1.427 raeburn 4568: %unesc_val,$selfenroll_end,$selfenroll_types,$created,
4569: $context);
1.384 raeburn 4570: $unesc_key = &unescape($key);
4571: if ($unesc_key =~ /^lasttime:/) {
4572: next;
4573: } else {
4574: $lasttime_key = &escape('lasttime:'.$unesc_key);
4575: }
4576: if ($hashref->{$lasttime_key} ne '') {
4577: $lasttime = $hashref->{$lasttime_key};
4578: next if ($lasttime<$since);
4579: }
1.419 raeburn 4580: my ($canclone,$valchange);
1.384 raeburn 4581: my $items = &Apache::lonnet::thaw_unescape($value);
4582: if (ref($items) eq 'HASH') {
1.429 raeburn 4583: if ($hashref->{$lasttime_key} eq '') {
1.430 raeburn 4584: next if ($since > 1);
1.429 raeburn 4585: }
1.384 raeburn 4586: $is_hash = 1;
1.445 raeburn 4587: if ($domcloner) {
4588: $canclone = 1;
4589: } elsif (defined($clonerudom)) {
1.419 raeburn 4590: if ($items->{'cloners'}) {
4591: my @cloneable = split(',',$items->{'cloners'});
4592: if (@cloneable) {
4593: if (grep(/^\*$/,@cloneable)) {
4594: $canclone = 1;
4595: } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
4596: $canclone = 1;
4597: } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
4598: $canclone = 1;
4599: }
4600: }
4601: unless ($canclone) {
4602: if ($cloneruname ne '' && $clonerudom ne '') {
4603: if ($cc_clone{$unesc_key}) {
4604: $canclone = 1;
4605: $items->{'cloners'} .= ','.$cloneruname.':'.
4606: $clonerudom;
4607: $valchange = 1;
4608: }
4609: }
4610: }
4611: } elsif (defined($cloneruname)) {
4612: if ($cc_clone{$unesc_key}) {
4613: $canclone = 1;
4614: $items->{'cloners'} = $cloneruname.':'.$clonerudom;
4615: $valchange = 1;
4616: }
1.437 raeburn 4617: unless ($canclone) {
4618: if ($items->{'owner'} =~ /:/) {
4619: if ($items->{'owner'} eq $cloner) {
4620: $canclone = 1;
4621: }
1.444 raeburn 4622: } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
1.437 raeburn 4623: $canclone = 1;
4624: }
4625: if ($canclone) {
4626: $items->{'cloners'} = $cloneruname.':'.$clonerudom;
4627: $valchange = 1;
4628: }
4629: }
1.419 raeburn 4630: }
4631: }
1.384 raeburn 4632: if ($unpack || !$rtn_as_hash) {
4633: $unesc_val{'descr'} = $items->{'description'};
4634: $unesc_val{'inst_code'} = $items->{'inst_code'};
4635: $unesc_val{'owner'} = $items->{'owner'};
4636: $unesc_val{'type'} = $items->{'type'};
1.419 raeburn 4637: $unesc_val{'cloners'} = $items->{'cloners'};
1.427 raeburn 4638: $unesc_val{'created'} = $items->{'created'};
4639: $unesc_val{'context'} = $items->{'context'};
1.404 raeburn 4640: }
4641: $selfenroll_types = $items->{'selfenroll_types'};
4642: $selfenroll_end = $items->{'selfenroll_end_date'};
1.427 raeburn 4643: $created = $items->{'created'};
4644: $context = $items->{'context'};
1.505 raeburn 4645: if ($hasuniquecode ne '.') {
4646: next unless ($items->{'uniquecode'});
4647: }
1.404 raeburn 4648: if ($selfenrollonly) {
4649: next if (!$selfenroll_types);
4650: if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
4651: next;
1.397 raeburn 4652: }
1.404 raeburn 4653: }
1.427 raeburn 4654: if ($creationcontext ne '.') {
4655: next if (($context ne '') && ($context ne $creationcontext));
4656: }
4657: if ($createdbefore > 0) {
4658: next if (($created eq '') || ($created > $createdbefore));
4659: }
4660: if ($createdafter > 0) {
4661: next if (($created eq '') || ($created <= $createdafter));
4662: }
1.404 raeburn 4663: if ($catfilter ne '') {
1.406 raeburn 4664: next if ($items->{'categories'} eq '');
4665: my @categories = split('&',$items->{'categories'});
1.407 raeburn 4666: next if (@categories == 0);
4667: my @subcats = split('&',$catfilter);
4668: my $matchcat = 0;
4669: foreach my $cat (@categories) {
4670: if (grep(/^\Q$cat\E$/,@subcats)) {
4671: $matchcat = 1;
4672: last;
4673: }
4674: }
4675: next if (!$matchcat);
1.404 raeburn 4676: }
4677: if ($caller eq 'coursecatalog') {
1.405 raeburn 4678: if ($items->{'hidefromcat'} eq 'yes') {
4679: next if !$showhidden;
1.401 raeburn 4680: }
1.384 raeburn 4681: }
1.383 raeburn 4682: } else {
1.401 raeburn 4683: next if ($catfilter ne '');
1.419 raeburn 4684: next if ($selfenrollonly);
1.427 raeburn 4685: next if ($createdbefore || $createdafter);
4686: next if ($creationcontext ne '.');
1.419 raeburn 4687: if ((defined($clonerudom)) && (defined($cloneruname))) {
4688: if ($cc_clone{$unesc_key}) {
4689: $canclone = 1;
4690: $val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
4691: }
4692: }
1.384 raeburn 4693: $is_hash = 0;
1.388 raeburn 4694: my @courseitems = split(/:/,$value);
1.403 raeburn 4695: $lasttime = pop(@courseitems);
1.402 raeburn 4696: if ($hashref->{$lasttime_key} eq '') {
4697: next if ($lasttime<$since);
4698: }
1.384 raeburn 4699: ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
1.383 raeburn 4700: }
1.419 raeburn 4701: if ($cloneonly) {
4702: next unless ($canclone);
4703: }
1.266 raeburn 4704: my $match = 1;
1.384 raeburn 4705: if ($description ne '.') {
4706: if (!$is_hash) {
4707: $unesc_val{'descr'} = &unescape($val{'descr'});
4708: }
4709: if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
1.266 raeburn 4710: $match = 0;
1.384 raeburn 4711: }
1.266 raeburn 4712: }
1.384 raeburn 4713: if ($instcodefilter ne '.') {
4714: if (!$is_hash) {
4715: $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
4716: }
1.418 raeburn 4717: if ($regexp_ok == 1) {
1.384 raeburn 4718: if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
1.344 raeburn 4719: $match = 0;
4720: }
1.418 raeburn 4721: } elsif ($regexp_ok == -1) {
4722: if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
4723: $match = 0;
4724: }
1.344 raeburn 4725: } else {
1.384 raeburn 4726: if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
1.344 raeburn 4727: $match = 0;
4728: }
1.266 raeburn 4729: }
1.234 foxr 4730: }
1.384 raeburn 4731: if ($ownerfilter ne '.') {
4732: if (!$is_hash) {
4733: $unesc_val{'owner'} = &unescape($val{'owner'});
4734: }
1.336 raeburn 4735: if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
1.384 raeburn 4736: if ($unesc_val{'owner'} =~ /:/) {
4737: if (eval{$unesc_val{'owner'} !~
4738: /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
1.336 raeburn 4739: $match = 0;
4740: }
4741: } else {
1.384 raeburn 4742: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
1.336 raeburn 4743: $match = 0;
4744: }
4745: }
4746: } elsif ($ownerunamefilter ne '') {
1.384 raeburn 4747: if ($unesc_val{'owner'} =~ /:/) {
4748: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
1.336 raeburn 4749: $match = 0;
4750: }
4751: } else {
1.384 raeburn 4752: if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
1.336 raeburn 4753: $match = 0;
4754: }
4755: }
4756: } elsif ($ownerdomfilter ne '') {
1.384 raeburn 4757: if ($unesc_val{'owner'} =~ /:/) {
4758: if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
1.336 raeburn 4759: $match = 0;
4760: }
4761: } else {
4762: if ($ownerdomfilter ne $udom) {
4763: $match = 0;
4764: }
4765: }
1.266 raeburn 4766: }
4767: }
1.384 raeburn 4768: if ($coursefilter ne '.') {
4769: if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
1.282 raeburn 4770: $match = 0;
4771: }
4772: }
1.384 raeburn 4773: if ($typefilter ne '.') {
4774: if (!$is_hash) {
4775: $unesc_val{'type'} = &unescape($val{'type'});
4776: }
4777: if ($unesc_val{'type'} eq '') {
1.333 raeburn 4778: if ($typefilter ne 'Course') {
4779: $match = 0;
4780: }
1.383 raeburn 4781: } else {
1.384 raeburn 4782: if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
1.333 raeburn 4783: $match = 0;
4784: }
4785: }
4786: }
1.266 raeburn 4787: if ($match == 1) {
1.384 raeburn 4788: if ($rtn_as_hash) {
4789: if ($is_hash) {
1.419 raeburn 4790: if ($valchange) {
4791: my $newvalue = &Apache::lonnet::freeze_escape($items);
4792: $qresult.=$key.'='.$newvalue.'&';
4793: } else {
4794: $qresult.=$key.'='.$value.'&';
4795: }
1.384 raeburn 4796: } else {
1.388 raeburn 4797: my %rtnhash = ( 'description' => &unescape($val{'descr'}),
4798: 'inst_code' => &unescape($val{'inst_code'}),
4799: 'owner' => &unescape($val{'owner'}),
4800: 'type' => &unescape($val{'type'}),
1.419 raeburn 4801: 'cloners' => &unescape($val{'cloners'}),
1.384 raeburn 4802: );
4803: my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
4804: $qresult.=$key.'='.$items.'&';
4805: }
1.383 raeburn 4806: } else {
1.384 raeburn 4807: if ($is_hash) {
4808: $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
4809: &escape($unesc_val{'inst_code'}).':'.
4810: &escape($unesc_val{'owner'}).'&';
4811: } else {
4812: $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
4813: ':'.$val{'owner'}.'&';
4814: }
1.383 raeburn 4815: }
1.266 raeburn 4816: }
1.234 foxr 4817: }
1.311 albertel 4818: if (&untie_domain_hash($hashref)) {
1.234 foxr 4819: chop($qresult);
1.387 albertel 4820: &Reply($client, \$qresult, $userinput);
1.234 foxr 4821: } else {
4822: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4823: "while attempting courseiddump\n", $userinput);
4824: }
4825: } else {
4826: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
4827: "while attempting courseiddump\n", $userinput);
4828: }
4829: return 1;
4830: }
4831: ®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
1.238 foxr 4832:
1.438 raeburn 4833: sub course_lastaccess_handler {
4834: my ($cmd, $tail, $client) = @_;
4835: my $userinput = "$cmd:$tail";
4836: my ($cdom,$cnum) = split(':',$tail);
4837: my (%lastaccess,$qresult);
4838: my $hashref = &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
4839: if ($hashref) {
4840: while (my ($key,$value) = each(%$hashref)) {
4841: my ($unesc_key,$lasttime);
4842: $unesc_key = &unescape($key);
4843: if ($cnum) {
4844: next unless ($unesc_key =~ /\Q$cdom\E_\Q$cnum\E$/);
4845: }
4846: if ($unesc_key =~ /^lasttime:($LONCAPA::match_domain\_$LONCAPA::match_courseid)/) {
4847: $lastaccess{$1} = $value;
4848: } else {
4849: my $items = &Apache::lonnet::thaw_unescape($value);
4850: if (ref($items) eq 'HASH') {
4851: unless ($lastaccess{$unesc_key}) {
4852: $lastaccess{$unesc_key} = '';
4853: }
4854: } else {
4855: my @courseitems = split(':',$value);
4856: $lastaccess{$unesc_key} = pop(@courseitems);
4857: }
4858: }
4859: }
4860: foreach my $cid (sort(keys(%lastaccess))) {
4861: $qresult.=&escape($cid).'='.$lastaccess{$cid}.'&';
4862: }
4863: if (&untie_domain_hash($hashref)) {
4864: if ($qresult) {
4865: chop($qresult);
4866: }
4867: &Reply($client, \$qresult, $userinput);
4868: } else {
4869: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4870: "while attempting lastacourseaccess\n", $userinput);
4871: }
4872: } else {
4873: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
4874: "while attempting lastcourseaccess\n", $userinput);
4875: }
4876: return 1;
4877: }
4878: ®ister_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);
4879:
1.561 raeburn 4880: sub course_sessions_handler {
4881: my ($cmd, $tail, $client) = @_;
4882: my $userinput = "$cmd:$tail";
4883: my ($cdom,$cnum,$lastactivity) = split(':',$tail);
4884: my $dbsuffix = '_'.$cdom.'_'.$cnum.'.db';
4885: my (%sessions,$qresult);
4886: my $now=time;
4887: if (opendir(DIR,$perlvar{'lonIDsDir'})) {
4888: my $filename;
4889: while ($filename=readdir(DIR)) {
4890: next if ($filename=~/^\./);
4891: next if ($filename=~/^publicuser_/);
4892: next if ($filename=~/^[a-f0-9]+_(linked|lti_\d+)\.id$/);
1.562 raeburn 4893: if ($filename =~ /^($LONCAPA::match_username)_\d+_($LONCAPA::match_domain)_/) {
1.561 raeburn 4894: my ($uname,$udom) = ($1,$2);
1.562 raeburn 4895: next unless (-e "$perlvar{'lonDaemons'}/tmp/$uname$dbsuffix");
1.561 raeburn 4896: my $mtime = (stat("$perlvar{'lonIDsDir'}/$filename"))[9];
4897: if ($lastactivity < 0) {
1.563 raeburn 4898: next if ($mtime-$now > $lastactivity);
1.561 raeburn 4899: } else {
1.563 raeburn 4900: next if ($now-$mtime > $lastactivity);
1.561 raeburn 4901: }
4902: $sessions{$uname.':'.$udom} = $mtime;
4903: }
4904: }
4905: closedir(DIR);
4906: }
4907: foreach my $user (keys(%sessions)) {
4908: $qresult.=&escape($user).'='.$sessions{$user}.'&';
4909: }
4910: if ($qresult) {
4911: chop($qresult);
4912: }
4913: &Reply($client, \$qresult, $userinput);
4914: return 1;
4915: }
4916: ®ister_handler("coursesessions",\&course_sessions_handler, 0, 1, 0);
4917:
1.238 foxr 4918: #
1.348 raeburn 4919: # Puts an unencrypted entry in a namespace db file at the domain level
4920: #
4921: # Parameters:
4922: # $cmd - The command that got us here.
4923: # $tail - Tail of the command (remaining parameters).
4924: # $client - File descriptor connected to client.
4925: # Returns
4926: # 0 - Requested to exit, caller should shut down.
4927: # 1 - Continue processing.
4928: # Side effects:
4929: # reply is written to $client.
4930: #
4931: sub put_domain_handler {
4932: my ($cmd,$tail,$client) = @_;
4933:
4934: my $userinput = "$cmd:$tail";
4935:
4936: my ($udom,$namespace,$what) =split(/:/,$tail,3);
4937: chomp($what);
4938: my @pairs=split(/\&/,$what);
4939: my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(),
4940: "P", $what);
4941: if ($hashref) {
4942: foreach my $pair (@pairs) {
4943: my ($key,$value)=split(/=/,$pair);
4944: $hashref->{$key}=$value;
4945: }
4946: if (&untie_domain_hash($hashref)) {
4947: &Reply($client, "ok\n", $userinput);
4948: } else {
4949: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
4950: "while attempting putdom\n", $userinput);
4951: }
4952: } else {
4953: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
4954: "while attempting putdom\n", $userinput);
4955: }
4956:
4957: return 1;
4958: }
4959: ®ister_handler("putdom", \&put_domain_handler, 0, 1, 0);
4960:
1.517 raeburn 4961: # Updates one or more entries in clickers.db file at the domain level
4962: #
4963: # Parameters:
4964: # $cmd - The command that got us here.
4965: # $tail - Tail of the command (remaining parameters).
4966: # In this case a colon separated list containing:
4967: # (a) the domain for which we are updating the entries,
4968: # (b) the action required -- add or del -- and
4969: # (c) a &-separated list of entries to add or delete.
4970: # $client - File descriptor connected to client.
4971: # Returns
4972: # 1 - Continue processing.
4973: # 0 - Requested to exit, caller should shut down.
4974: # Side effects:
4975: # reply is written to $client.
4976: #
4977:
4978:
4979: sub update_clickers {
4980: my ($cmd, $tail, $client) = @_;
4981:
4982: my $userinput = "$cmd:$tail";
4983: my ($udom,$action,$what) =split(/:/,$tail,3);
4984: chomp($what);
4985:
4986: my $hashref = &tie_domain_hash($udom, "clickers", &GDBM_WRCREAT(),
4987: "U","$action:$what");
4988:
4989: if (!$hashref) {
4990: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
4991: "while attempting updateclickers\n", $userinput);
4992: return 1;
4993: }
4994:
4995: my @pairs=split(/\&/,$what);
4996: foreach my $pair (@pairs) {
4997: my ($key,$value)=split(/=/,$pair);
4998: if ($action eq 'add') {
4999: if (exists($hashref->{$key})) {
5000: my @newvals = split(/,/,&unescape($value));
5001: my @currvals = split(/,/,&unescape($hashref->{$key}));
5002: my @merged = sort(keys(%{{map { $_ => 1 } (@newvals,@currvals)}}));
5003: $hashref->{$key}=&escape(join(',',@merged));
5004: } else {
5005: $hashref->{$key}=$value;
5006: }
5007: } elsif ($action eq 'del') {
5008: if (exists($hashref->{$key})) {
5009: my %current;
5010: map { $current{$_} = 1; } split(/,/,&unescape($hashref->{$key}));
5011: map { delete($current{$_}); } split(/,/,&unescape($value));
5012: if (keys(%current)) {
5013: $hashref->{$key}=&escape(join(',',sort(keys(%current))));
5014: } else {
5015: delete($hashref->{$key});
5016: }
5017: }
5018: }
5019: }
5020: if (&untie_user_hash($hashref)) {
5021: &Reply( $client, "ok\n", $userinput);
5022: } else {
5023: &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
5024: "while attempting put\n",
5025: $userinput);
5026: }
5027: return 1;
5028: }
5029: ®ister_handler("updateclickers", \&update_clickers, 0, 1, 0);
5030:
5031:
5032: # Deletes one or more entries in a namespace db file at the domain level
5033: #
5034: # Parameters:
5035: # $cmd - The command that got us here.
5036: # $tail - Tail of the command (remaining parameters).
5037: # In this case a colon separated list containing:
5038: # (a) the domain for which we are deleting the entries,
5039: # (b) &-separated list of keys to delete.
5040: # $client - File descriptor connected to client.
5041: # Returns
5042: # 1 - Continue processing.
5043: # 0 - Requested to exit, caller should shut down.
5044: # Side effects:
5045: # reply is written to $client.
5046: #
5047:
5048: sub del_domain_handler {
5049: my ($cmd,$tail,$client) = @_;
5050:
5051: my $userinput = "$cmd:$tail";
5052:
5053: my ($udom,$namespace,$what)=split(/:/,$tail,3);
5054: chomp($what);
5055: my $hashref = &tie_domain_hash($udom,$namespace,&GDBM_WRCREAT(),
5056: "D", $what);
5057: if ($hashref) {
5058: my @keys=split(/\&/,$what);
5059: foreach my $key (@keys) {
5060: delete($hashref->{$key});
5061: }
5062: if (&untie_user_hash($hashref)) {
5063: &Reply($client, "ok\n", $userinput);
5064: } else {
5065: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
5066: "while attempting deldom\n", $userinput);
5067: }
5068: } else {
5069: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
5070: "while attempting deldom\n", $userinput);
5071: }
5072: return 1;
5073: }
5074: ®ister_handler("deldom", \&del_domain_handler, 0, 1, 0);
5075:
5076:
1.348 raeburn 5077: # Unencrypted get from the namespace database file at the domain level.
5078: # This function retrieves a keyed item from a specific named database in the
5079: # domain directory.
5080: #
5081: # Parameters:
1.565 raeburn 5082: # $cmd - Command request keyword (getdom).
1.348 raeburn 5083: # $tail - Tail of the command. This is a colon separated list
5084: # consisting of the domain and the 'namespace'
5085: # which selects the gdbm file to do the lookup in,
5086: # & separated list of keys to lookup. Note that
5087: # the values are returned as an & separated list too.
5088: # $client - File descriptor open on the client.
5089: # Returns:
5090: # 1 - Continue processing.
5091: # 0 - Exit.
5092: # Side effects:
5093: # reply is written to $client.
5094: #
5095:
5096: sub get_domain_handler {
5097: my ($cmd, $tail, $client) = @_;
5098:
1.536 raeburn 5099: my $userinput = "$cmd:$tail";
5100:
5101: my ($udom,$namespace,$what)=split(/:/,$tail,3);
5102: if ($namespace =~ /^enc/) {
5103: &Failure( $client, "refused\n", $userinput);
5104: } else {
1.565 raeburn 5105: my $res = LONCAPA::Lond::get_dom($userinput);
5106: if ($res =~ /^error:/) {
5107: &Failure($client, \$res, $userinput);
1.536 raeburn 5108: } else {
1.565 raeburn 5109: &Reply($client, \$res, $userinput);
1.536 raeburn 5110: }
5111: }
5112:
5113: return 1;
5114: }
5115: ®ister_handler("getdom", \&get_domain_handler, 0, 1, 0);
5116:
5117: sub encrypted_get_domain_handler {
5118: my ($cmd, $tail, $client) = @_;
5119:
5120: my $userinput = "$cmd:$tail";
1.348 raeburn 5121:
1.565 raeburn 5122: my $res = LONCAPA::Lond::get_dom($userinput);
5123: if ($res =~ /^error:/) {
5124: &Failure($client, \$res, $userinput);
5125: } else {
5126: if ($cipher) {
5127: my $cmdlength=length($res);
5128: $res.=" ";
5129: my $encres='';
5130: for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
5131: $encres.= unpack("H16",
5132: $cipher->encrypt(substr($res,
5133: $encidx,
5134: 8)));
1.536 raeburn 5135: }
1.565 raeburn 5136: &Reply( $client,"enc:$cmdlength:$encres\n",$userinput);
1.348 raeburn 5137: } else {
1.565 raeburn 5138: &Failure( $client, "error:no_key\n",$userinput);
1.348 raeburn 5139: }
5140: }
5141: return 1;
5142: }
1.536 raeburn 5143: ®ister_handler("egetdom", \&encrypted_get_domain_handler, 1, 1, 0);
1.348 raeburn 5144:
1.420 raeburn 5145: #
1.238 foxr 5146: # Puts an id to a domains id database.
5147: #
5148: # Parameters:
5149: # $cmd - The command that triggered us.
5150: # $tail - Remainder of the request other than the command. This is a
5151: # colon separated list containing:
5152: # $domain - The domain for which we are writing the id.
5153: # $pairs - The id info to write... this is and & separated list
5154: # of keyword=value.
5155: # $client - Socket open on the client.
5156: # Returns:
5157: # 1 - Continue processing.
5158: # Side effects:
5159: # reply is written to $client.
5160: #
5161: sub put_id_handler {
5162: my ($cmd,$tail,$client) = @_;
5163:
5164:
5165: my $userinput = "$cmd:$tail";
5166:
5167: my ($udom,$what)=split(/:/,$tail);
5168: chomp($what);
5169: my @pairs=split(/\&/,$what);
5170: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(),
5171: "P", $what);
5172: if ($hashref) {
5173: foreach my $pair (@pairs) {
5174: my ($key,$value)=split(/=/,$pair);
5175: $hashref->{$key}=$value;
5176: }
1.311 albertel 5177: if (&untie_domain_hash($hashref)) {
1.238 foxr 5178: &Reply($client, "ok\n", $userinput);
5179: } else {
5180: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
5181: "while attempting idput\n", $userinput);
5182: }
5183: } else {
5184: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
5185: "while attempting idput\n", $userinput);
5186: }
5187:
5188: return 1;
5189: }
1.263 albertel 5190: ®ister_handler("idput", \&put_id_handler, 0, 1, 0);
1.238 foxr 5191:
5192: #
5193: # Retrieves a set of id values from the id database.
5194: # Returns an & separated list of results, one for each requested id to the
5195: # client.
5196: #
5197: # Parameters:
5198: # $cmd - Command keyword that caused us to be dispatched.
5199: # $tail - Tail of the command. Consists of a colon separated:
5200: # domain - the domain whose id table we dump
5201: # ids Consists of an & separated list of
5202: # id keywords whose values will be fetched.
5203: # nonexisting keywords will have an empty value.
5204: # $client - Socket open on the client.
5205: #
5206: # Returns:
5207: # 1 - indicating processing should continue.
5208: # Side effects:
5209: # An & separated list of results is written to $client.
5210: #
5211: sub get_id_handler {
5212: my ($cmd, $tail, $client) = @_;
5213:
5214:
5215: my $userinput = "$client:$tail";
5216:
5217: my ($udom,$what)=split(/:/,$tail);
5218: chomp($what);
5219: my @queries=split(/\&/,$what);
5220: my $qresult='';
5221: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_READER());
5222: if ($hashref) {
5223: for (my $i=0;$i<=$#queries;$i++) {
5224: $qresult.="$hashref->{$queries[$i]}&";
5225: }
1.311 albertel 5226: if (&untie_domain_hash($hashref)) {
1.238 foxr 5227: $qresult=~s/\&$//;
1.387 albertel 5228: &Reply($client, \$qresult, $userinput);
1.238 foxr 5229: } else {
5230: &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
5231: "while attempting idget\n",$userinput);
5232: }
5233: } else {
5234: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
5235: "while attempting idget\n",$userinput);
5236: }
5237:
5238: return 1;
5239: }
1.263 albertel 5240: ®ister_handler("idget", \&get_id_handler, 0, 1, 0);
1.238 foxr 5241:
1.501 raeburn 5242: # Deletes one or more ids in a domain's id database.
5243: #
5244: # Parameters:
5245: # $cmd - Command keyword (iddel).
5246: # $tail - Command tail. In this case a colon
5247: # separated list containing:
5248: # The domain for which we are deleting the id(s).
5249: # &-separated list of id(s) to delete.
5250: # $client - File open on client socket.
5251: # Returns:
5252: # 1 - Continue processing
5253: # 0 - Exit server.
5254: #
5255: #
5256:
5257: sub del_id_handler {
5258: my ($cmd,$tail,$client) = @_;
5259:
5260: my $userinput = "$cmd:$tail";
5261:
5262: my ($udom,$what)=split(/:/,$tail);
5263: chomp($what);
5264: my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(),
5265: "D", $what);
5266: if ($hashref) {
5267: my @keys=split(/\&/,$what);
5268: foreach my $key (@keys) {
5269: delete($hashref->{$key});
5270: }
5271: if (&untie_user_hash($hashref)) {
5272: &Reply($client, "ok\n", $userinput);
5273: } else {
5274: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
5275: "while attempting iddel\n", $userinput);
5276: }
5277: } else {
5278: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
5279: "while attempting iddel\n", $userinput);
5280: }
5281: return 1;
5282: }
5283: ®ister_handler("iddel", \&del_id_handler, 0, 1, 0);
5284:
1.238 foxr 5285: #
1.299 raeburn 5286: # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database
5287: #
5288: # Parameters
5289: # $cmd - Command keyword that caused us to be dispatched.
5290: # $tail - Tail of the command. Consists of a colon separated:
5291: # domain - the domain whose dcmail we are recording
5292: # email Consists of key=value pair
5293: # where key is unique msgid
5294: # and value is message (in XML)
5295: # $client - Socket open on the client.
5296: #
5297: # Returns:
5298: # 1 - indicating processing should continue.
5299: # Side effects
5300: # reply is written to $client.
5301: #
5302: sub put_dcmail_handler {
5303: my ($cmd,$tail,$client) = @_;
5304: my $userinput = "$cmd:$tail";
1.463 foxr 5305:
5306:
1.299 raeburn 5307: my ($udom,$what)=split(/:/,$tail);
5308: chomp($what);
5309: my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
5310: if ($hashref) {
5311: my ($key,$value)=split(/=/,$what);
5312: $hashref->{$key}=$value;
5313: }
1.311 albertel 5314: if (&untie_domain_hash($hashref)) {
1.299 raeburn 5315: &Reply($client, "ok\n", $userinput);
5316: } else {
5317: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
5318: "while attempting dcmailput\n", $userinput);
5319: }
5320: return 1;
5321: }
5322: ®ister_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0);
5323:
5324: #
5325: # Retrieves broadcast e-mail from nohist_dcmail database
5326: # Returns to client an & separated list of key=value pairs,
5327: # where key is msgid and value is message information.
5328: #
5329: # Parameters
5330: # $cmd - Command keyword that caused us to be dispatched.
5331: # $tail - Tail of the command. Consists of a colon separated:
5332: # domain - the domain whose dcmail table we dump
5333: # startfilter - beginning of time window
5334: # endfilter - end of time window
5335: # sendersfilter - & separated list of username:domain
5336: # for senders to search for.
5337: # $client - Socket open on the client.
5338: #
5339: # Returns:
5340: # 1 - indicating processing should continue.
5341: # Side effects
5342: # reply (& separated list of msgid=messageinfo pairs) is
5343: # written to $client.
5344: #
5345: sub dump_dcmail_handler {
5346: my ($cmd, $tail, $client) = @_;
5347:
5348: my $userinput = "$cmd:$tail";
5349: my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail);
5350: chomp($sendersfilter);
5351: my @senders = ();
5352: if (defined($startfilter)) {
5353: $startfilter=&unescape($startfilter);
5354: } else {
5355: $startfilter='.';
5356: }
5357: if (defined($endfilter)) {
5358: $endfilter=&unescape($endfilter);
5359: } else {
5360: $endfilter='.';
5361: }
5362: if (defined($sendersfilter)) {
5363: $sendersfilter=&unescape($sendersfilter);
1.300 albertel 5364: @senders = map { &unescape($_) } split(/\&/,$sendersfilter);
1.299 raeburn 5365: }
5366:
5367: my $qresult='';
5368: my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
5369: if ($hashref) {
5370: while (my ($key,$value) = each(%$hashref)) {
5371: my $match = 1;
1.303 albertel 5372: my ($timestamp,$subj,$uname,$udom) =
5373: split(/:/,&unescape(&unescape($key)),5); # yes, twice really
1.299 raeburn 5374: $subj = &unescape($subj);
5375: unless ($startfilter eq '.' || !defined($startfilter)) {
5376: if ($timestamp < $startfilter) {
5377: $match = 0;
5378: }
5379: }
5380: unless ($endfilter eq '.' || !defined($endfilter)) {
5381: if ($timestamp > $endfilter) {
5382: $match = 0;
5383: }
5384: }
5385: unless (@senders < 1) {
5386: unless (grep/^$uname:$udom$/,@senders) {
5387: $match = 0;
5388: }
5389: }
5390: if ($match == 1) {
5391: $qresult.=$key.'='.$value.'&';
5392: }
5393: }
1.311 albertel 5394: if (&untie_domain_hash($hashref)) {
1.299 raeburn 5395: chop($qresult);
1.387 albertel 5396: &Reply($client, \$qresult, $userinput);
1.299 raeburn 5397: } else {
5398: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
5399: "while attempting dcmaildump\n", $userinput);
5400: }
5401: } else {
5402: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
5403: "while attempting dcmaildump\n", $userinput);
5404: }
5405: return 1;
5406: }
5407:
5408: ®ister_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0);
5409:
5410: #
5411: # Puts domain roles in nohist_domainroles database
5412: #
5413: # Parameters
5414: # $cmd - Command keyword that caused us to be dispatched.
5415: # $tail - Tail of the command. Consists of a colon separated:
5416: # domain - the domain whose roles we are recording
5417: # role - Consists of key=value pair
5418: # where key is unique role
5419: # and value is start/end date information
5420: # $client - Socket open on the client.
5421: #
5422: # Returns:
5423: # 1 - indicating processing should continue.
5424: # Side effects
5425: # reply is written to $client.
5426: #
5427:
5428: sub put_domainroles_handler {
5429: my ($cmd,$tail,$client) = @_;
5430:
5431: my $userinput = "$cmd:$tail";
5432: my ($udom,$what)=split(/:/,$tail);
5433: chomp($what);
5434: my @pairs=split(/\&/,$what);
5435: my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
5436: if ($hashref) {
5437: foreach my $pair (@pairs) {
5438: my ($key,$value)=split(/=/,$pair);
5439: $hashref->{$key}=$value;
5440: }
1.311 albertel 5441: if (&untie_domain_hash($hashref)) {
1.299 raeburn 5442: &Reply($client, "ok\n", $userinput);
5443: } else {
5444: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
5445: "while attempting domroleput\n", $userinput);
5446: }
5447: } else {
5448: &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
5449: "while attempting domroleput\n", $userinput);
5450: }
5451:
5452: return 1;
5453: }
5454:
5455: ®ister_handler("domroleput", \&put_domainroles_handler, 0, 1, 0);
5456:
5457: #
5458: # Retrieves domain roles from nohist_domainroles database
5459: # Returns to client an & separated list of key=value pairs,
5460: # where key is role and value is start and end date information.
5461: #
5462: # Parameters
5463: # $cmd - Command keyword that caused us to be dispatched.
5464: # $tail - Tail of the command. Consists of a colon separated:
5465: # domain - the domain whose domain roles table we dump
5466: # $client - Socket open on the client.
5467: #
5468: # Returns:
5469: # 1 - indicating processing should continue.
5470: # Side effects
5471: # reply (& separated list of role=start/end info pairs) is
5472: # written to $client.
5473: #
5474: sub dump_domainroles_handler {
5475: my ($cmd, $tail, $client) = @_;
5476:
5477: my $userinput = "$cmd:$tail";
5478: my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail);
5479: chomp($rolesfilter);
5480: my @roles = ();
5481: if (defined($startfilter)) {
5482: $startfilter=&unescape($startfilter);
5483: } else {
5484: $startfilter='.';
5485: }
5486: if (defined($endfilter)) {
5487: $endfilter=&unescape($endfilter);
5488: } else {
5489: $endfilter='.';
5490: }
5491: if (defined($rolesfilter)) {
5492: $rolesfilter=&unescape($rolesfilter);
1.300 albertel 5493: @roles = split(/\&/,$rolesfilter);
1.299 raeburn 5494: }
1.421 raeburn 5495:
1.299 raeburn 5496: my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
5497: if ($hashref) {
5498: my $qresult = '';
5499: while (my ($key,$value) = each(%$hashref)) {
5500: my $match = 1;
1.421 raeburn 5501: my ($end,$start) = split(/:/,&unescape($value));
1.299 raeburn 5502: my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
1.421 raeburn 5503: unless (@roles < 1) {
5504: unless (grep/^\Q$trole\E$/,@roles) {
5505: $match = 0;
5506: next;
5507: }
5508: }
1.299 raeburn 5509: unless ($startfilter eq '.' || !defined($startfilter)) {
1.415 raeburn 5510: if ((defined($start)) && ($start >= $startfilter)) {
1.299 raeburn 5511: $match = 0;
1.421 raeburn 5512: next;
1.299 raeburn 5513: }
5514: }
5515: unless ($endfilter eq '.' || !defined($endfilter)) {
1.421 raeburn 5516: if ((defined($end)) && (($end > 0) && ($end <= $endfilter))) {
1.299 raeburn 5517: $match = 0;
1.421 raeburn 5518: next;
1.299 raeburn 5519: }
5520: }
5521: if ($match == 1) {
5522: $qresult.=$key.'='.$value.'&';
5523: }
5524: }
1.311 albertel 5525: if (&untie_domain_hash($hashref)) {
1.299 raeburn 5526: chop($qresult);
1.387 albertel 5527: &Reply($client, \$qresult, $userinput);
1.299 raeburn 5528: } else {
5529: &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
5530: "while attempting domrolesdump\n", $userinput);
5531: }
5532: } else {
5533: &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
5534: "while attempting domrolesdump\n", $userinput);
5535: }
5536: return 1;
5537: }
5538:
5539: ®ister_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0);
5540:
5541:
1.238 foxr 5542: # Process the tmpput command I'm not sure what this does.. Seems to
5543: # create a file in the lonDaemons/tmp directory of the form $id.tmp
5544: # where Id is the client's ip concatenated with a sequence number.
5545: # The file will contain some value that is passed in. Is this e.g.
5546: # a login token?
5547: #
5548: # Parameters:
5549: # $cmd - The command that got us dispatched.
5550: # $tail - The remainder of the request following $cmd:
5551: # In this case this will be the contents of the file.
5552: # $client - Socket connected to the client.
5553: # Returns:
5554: # 1 indicating processing can continue.
5555: # Side effects:
5556: # A file is created in the local filesystem.
5557: # A reply is sent to the client.
5558: sub tmp_put_handler {
5559: my ($cmd, $what, $client) = @_;
5560:
5561: my $userinput = "$cmd:$what"; # Reconstruct for logging.
5562:
1.347 raeburn 5563: my ($record,$context) = split(/:/,$what);
5564: if ($context ne '') {
5565: chomp($context);
5566: $context = &unescape($context);
5567: }
5568: my ($id,$store);
1.238 foxr 5569: $tmpsnum++;
1.454 raeburn 5570: if (($context eq 'resetpw') || ($context eq 'createaccount')) {
1.347 raeburn 5571: $id = &md5_hex(&md5_hex(time.{}.rand().$$));
5572: } else {
5573: $id = $$.'_'.$clientip.'_'.$tmpsnum;
5574: }
1.238 foxr 5575: $id=~s/\W/\_/g;
1.347 raeburn 5576: $record=~s/\n//g;
1.238 foxr 5577: my $execdir=$perlvar{'lonDaemons'};
5578: if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
1.347 raeburn 5579: print $store $record;
1.238 foxr 5580: close $store;
1.387 albertel 5581: &Reply($client, \$id, $userinput);
1.238 foxr 5582: } else {
5583: &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
5584: "while attempting tmpput\n", $userinput);
5585: }
5586: return 1;
5587:
5588: }
5589: ®ister_handler("tmpput", \&tmp_put_handler, 0, 1, 0);
1.263 albertel 5590:
1.238 foxr 5591: # Processes the tmpget command. This command returns the contents
5592: # of a temporary resource file(?) created via tmpput.
5593: #
5594: # Paramters:
5595: # $cmd - Command that got us dispatched.
5596: # $id - Tail of the command, contain the id of the resource
5597: # we want to fetch.
5598: # $client - socket open on the client.
5599: # Return:
5600: # 1 - Inidcating processing can continue.
5601: # Side effects:
5602: # A reply is sent to the client.
5603: #
5604: sub tmp_get_handler {
5605: my ($cmd, $id, $client) = @_;
5606:
5607: my $userinput = "$cmd:$id";
5608:
5609:
5610: $id=~s/\W/\_/g;
5611: my $store;
5612: my $execdir=$perlvar{'lonDaemons'};
5613: if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
5614: my $reply=<$store>;
1.387 albertel 5615: &Reply( $client, \$reply, $userinput);
1.238 foxr 5616: close $store;
5617: } else {
5618: &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
5619: "while attempting tmpget\n", $userinput);
5620: }
5621:
5622: return 1;
5623: }
5624: ®ister_handler("tmpget", \&tmp_get_handler, 0, 1, 0);
1.263 albertel 5625:
1.238 foxr 5626: #
5627: # Process the tmpdel command. This command deletes a temp resource
5628: # created by the tmpput command.
5629: #
5630: # Parameters:
5631: # $cmd - Command that got us here.
5632: # $id - Id of the temporary resource created.
5633: # $client - socket open on the client process.
5634: #
5635: # Returns:
5636: # 1 - Indicating processing should continue.
5637: # Side Effects:
5638: # A file is deleted
5639: # A reply is sent to the client.
5640: sub tmp_del_handler {
5641: my ($cmd, $id, $client) = @_;
5642:
5643: my $userinput= "$cmd:$id";
5644:
5645: chomp($id);
5646: $id=~s/\W/\_/g;
5647: my $execdir=$perlvar{'lonDaemons'};
5648: if (unlink("$execdir/tmp/$id.tmp")) {
5649: &Reply($client, "ok\n", $userinput);
5650: } else {
5651: &Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".
5652: "while attempting tmpdel\n", $userinput);
5653: }
5654:
5655: return 1;
5656:
5657: }
5658: ®ister_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);
1.263 albertel 5659:
1.238 foxr 5660: #
1.564 raeburn 5661: # Process the updatebalcookie command. This command updates a
5662: # cookie in the lonBalancedir directory on a load balancer node.
5663: #
5664: # Parameters:
5665: # $cmd - Command that got us here.
5666: # $tail - Tail of the request (escaped cookie: escaped current entry)
5667: #
5668: # $client - socket open on the client process.
5669: #
5670: # Returns:
5671: # 1 - Indicating processing should continue.
5672: # Side Effects:
5673: # A cookie file is updated from the lonBalancedir directory
5674: # A reply is sent to the client.
5675: #
5676: sub update_balcookie_handler {
5677: my ($cmd, $tail, $client) = @_;
5678:
5679: my $userinput= "$cmd:$tail";
5680: chomp($tail);
5681: my ($cookie,$lastentry) = map { &unescape($_) } (split(/:/,$tail));
5682:
5683: my $updatedone;
5684: if ($cookie =~ /^$LONCAPA::match_domain\_$LONCAPA::match_username\_[a-f0-9]{32}$/) {
5685: my $execdir=$perlvar{'lonBalanceDir'};
5686: if (-e "$execdir/$cookie.id") {
5687: my $doupdate;
5688: if (open(my $fh,'<',"$execdir/$cookie.id")) {
5689: while (my $line = <$fh>) {
5690: chomp($line);
5691: if ($line eq $lastentry) {
5692: $doupdate = 1;
5693: last;
5694: }
5695: }
5696: close($fh);
5697: }
5698: if ($doupdate) {
5699: if (open(my $fh,'>',"$execdir/$cookie.id")) {
5700: print $fh $clientname;
5701: close($fh);
5702: $updatedone = 1;
5703: }
5704: }
5705: }
5706: }
5707: if ($updatedone) {
5708: &Reply($client, "ok\n", $userinput);
5709: } else {
5710: &Failure( $client, "error: ".($!+0)."file update failed ".
5711: "while attempting updatebalcookie\n", $userinput);
5712: }
5713: return 1;
5714: }
5715: ®ister_handler("updatebalcookie", \&update_balcookie_handler, 0, 1, 0);
5716:
5717: #
1.551 raeburn 5718: # Process the delbalcookie command. This command deletes a balancer
1.564 raeburn 5719: # cookie in the lonBalancedir directory on a load balancer node.
1.551 raeburn 5720: #
5721: # Parameters:
5722: # $cmd - Command that got us here.
5723: # $cookie - Cookie to be deleted.
5724: # $client - socket open on the client process.
5725: #
5726: # Returns:
5727: # 1 - Indicating processing should continue.
5728: # Side Effects:
5729: # A cookie file is deleted from the lonBalancedir directory
5730: # A reply is sent to the client.
5731: sub del_balcookie_handler {
5732: my ($cmd, $cookie, $client) = @_;
5733:
5734: my $userinput= "$cmd:$cookie";
5735:
5736: chomp($cookie);
1.564 raeburn 5737: $cookie = &unescape($cookie);
1.551 raeburn 5738: my $deleted = '';
5739: if ($cookie =~ /^$LONCAPA::match_domain\_$LONCAPA::match_username\_[a-f0-9]{32}$/) {
5740: my $execdir=$perlvar{'lonBalanceDir'};
5741: if (-e "$execdir/$cookie.id") {
5742: if (open(my $fh,'<',"$execdir/$cookie.id")) {
5743: my $dodelete;
5744: while (my $line = <$fh>) {
5745: chomp($line);
5746: if ($line eq $clientname) {
5747: $dodelete = 1;
1.554 raeburn 5748: last;
1.551 raeburn 5749: }
5750: }
1.554 raeburn 5751: close($fh);
1.551 raeburn 5752: if ($dodelete) {
5753: if (unlink("$execdir/$cookie.id")) {
5754: $deleted = 1;
5755: }
5756: }
5757: }
5758: }
5759: }
5760: if ($deleted) {
5761: &Reply($client, "ok\n", $userinput);
5762: } else {
5763: &Failure( $client, "error: ".($!+0)."Unlinking cookie file Failed ".
5764: "while attempting delbalcookie\n", $userinput);
5765: }
5766: return 1;
5767: }
5768: ®ister_handler("delbalcookie", \&del_balcookie_handler, 0, 1, 0);
5769:
5770: #
1.246 foxr 5771: # Processes the setannounce command. This command
5772: # creates a file named announce.txt in the top directory of
5773: # the documentn root and sets its contents. The announce.txt file is
5774: # printed in its entirety at the LonCAPA login page. Note:
5775: # once the announcement.txt fileis created it cannot be deleted.
5776: # However, setting the contents of the file to empty removes the
5777: # announcement from the login page of loncapa so who cares.
5778: #
5779: # Parameters:
5780: # $cmd - The command that got us dispatched.
5781: # $announcement - The text of the announcement.
5782: # $client - Socket open on the client process.
5783: # Retunrns:
5784: # 1 - Indicating request processing should continue
5785: # Side Effects:
5786: # The file {DocRoot}/announcement.txt is created.
5787: # A reply is sent to $client.
5788: #
5789: sub set_announce_handler {
5790: my ($cmd, $announcement, $client) = @_;
5791:
5792: my $userinput = "$cmd:$announcement";
5793:
5794: chomp($announcement);
5795: $announcement=&unescape($announcement);
5796: if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
5797: '/announcement.txt')) {
5798: print $store $announcement;
5799: close $store;
5800: &Reply($client, "ok\n", $userinput);
5801: } else {
5802: &Failure($client, "error: ".($!+0)."\n", $userinput);
5803: }
5804:
5805: return 1;
5806: }
5807: ®ister_handler("setannounce", \&set_announce_handler, 0, 1, 0);
1.263 albertel 5808:
1.246 foxr 5809: #
5810: # Return the version of the daemon. This can be used to determine
5811: # the compatibility of cross version installations or, alternatively to
5812: # simply know who's out of date and who isn't. Note that the version
5813: # is returned concatenated with the tail.
5814: # Parameters:
5815: # $cmd - the request that dispatched to us.
5816: # $tail - Tail of the request (client's version?).
5817: # $client - Socket open on the client.
5818: #Returns:
5819: # 1 - continue processing requests.
5820: # Side Effects:
5821: # Replies with version to $client.
5822: sub get_version_handler {
5823: my ($cmd, $tail, $client) = @_;
5824:
5825: my $userinput = $cmd.$tail;
5826:
5827: &Reply($client, &version($userinput)."\n", $userinput);
5828:
5829:
5830: return 1;
5831: }
5832: ®ister_handler("version", \&get_version_handler, 0, 1, 0);
1.263 albertel 5833:
1.246 foxr 5834: # Set the current host and domain. This is used to support
5835: # multihomed systems. Each IP of the system, or even separate daemons
5836: # on the same IP can be treated as handling a separate lonCAPA virtual
5837: # machine. This command selects the virtual lonCAPA. The client always
5838: # knows the right one since it is lonc and it is selecting the domain/system
5839: # from the hosts.tab file.
5840: # Parameters:
5841: # $cmd - Command that dispatched us.
5842: # $tail - Tail of the command (domain/host requested).
5843: # $socket - Socket open on the client.
5844: #
5845: # Returns:
5846: # 1 - Indicates the program should continue to process requests.
5847: # Side-effects:
5848: # The default domain/system context is modified for this daemon.
5849: # a reply is sent to the client.
5850: #
5851: sub set_virtual_host_handler {
5852: my ($cmd, $tail, $socket) = @_;
5853:
5854: my $userinput ="$cmd:$tail";
5855:
5856: &Reply($client, &sethost($userinput)."\n", $userinput);
5857:
5858:
5859: return 1;
5860: }
1.247 albertel 5861: ®ister_handler("sethost", \&set_virtual_host_handler, 0, 1, 0);
1.246 foxr 5862:
5863: # Process a request to exit:
5864: # - "bye" is sent to the client.
5865: # - The client socket is shutdown and closed.
5866: # - We indicate to the caller that we should exit.
5867: # Formal Parameters:
5868: # $cmd - The command that got us here.
5869: # $tail - Tail of the command (empty).
5870: # $client - Socket open on the tail.
5871: # Returns:
5872: # 0 - Indicating the program should exit!!
5873: #
5874: sub exit_handler {
5875: my ($cmd, $tail, $client) = @_;
5876:
5877: my $userinput = "$cmd:$tail";
5878:
5879: &logthis("Client $clientip ($clientname) hanging up: $userinput");
5880: &Reply($client, "bye\n", $userinput);
5881: $client->shutdown(2); # shutdown the socket forcibly.
5882: $client->close();
5883:
5884: return 0;
5885: }
1.248 foxr 5886: ®ister_handler("exit", \&exit_handler, 0,1,1);
5887: ®ister_handler("init", \&exit_handler, 0,1,1);
5888: ®ister_handler("quit", \&exit_handler, 0,1,1);
5889:
5890: # Determine if auto-enrollment is enabled.
5891: # Note that the original had what I believe to be a defect.
5892: # The original returned 0 if the requestor was not a registerd client.
5893: # It should return "refused".
5894: # Formal Parameters:
5895: # $cmd - The command that invoked us.
5896: # $tail - The tail of the command (Extra command parameters.
5897: # $client - The socket open on the client that issued the request.
5898: # Returns:
5899: # 1 - Indicating processing should continue.
5900: #
5901: sub enrollment_enabled_handler {
5902: my ($cmd, $tail, $client) = @_;
5903: my $userinput = $cmd.":".$tail; # For logging purposes.
5904:
5905:
1.337 albertel 5906: my ($cdom) = split(/:/, $tail, 2); # Domain we're asking about.
5907:
1.248 foxr 5908: my $outcome = &localenroll::run($cdom);
1.387 albertel 5909: &Reply($client, \$outcome, $userinput);
1.248 foxr 5910:
5911: return 1;
5912: }
5913: ®ister_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
5914:
1.417 raeburn 5915: #
1.423 raeburn 5916: # Validate an institutional code used for a LON-CAPA course.
1.417 raeburn 5917: #
5918: # Formal Parameters:
5919: # $cmd - The command request that got us dispatched.
5920: # $tail - The tail of the command. In this case,
5921: # this is a colon separated set of words that will be split
5922: # into:
1.424 raeburn 5923: # $dom - The domain for which the check of
5924: # institutional course code will occur.
5925: #
5926: # $instcode - The institutional code for the course
5927: # being requested, or validated for rights
5928: # to request.
5929: #
5930: # $owner - The course requestor (who will be the
5931: # course owner, in the form username:domain
5932: #
1.417 raeburn 5933: # $client - Socket open on the client.
5934: # Returns:
5935: # 1 - Indicating processing should continue.
5936: #
5937: sub validate_instcode_handler {
5938: my ($cmd, $tail, $client) = @_;
5939: my $userinput = "$cmd:$tail";
1.423 raeburn 5940: my ($dom,$instcode,$owner) = split(/:/, $tail);
1.422 raeburn 5941: $instcode = &unescape($instcode);
5942: $owner = &unescape($owner);
1.498 raeburn 5943: my ($outcome,$description,$credits) =
1.426 raeburn 5944: &localenroll::validate_instcode($dom,$instcode,$owner);
1.498 raeburn 5945: my $result = &escape($outcome).'&'.&escape($description).'&'.
5946: &escape($credits);
1.426 raeburn 5947: &Reply($client, \$result, $userinput);
1.417 raeburn 5948:
5949: return 1;
5950: }
5951: ®ister_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0);
5952:
1.566 raeburn 5953: #
5954: # Validate co-owner for cross-listed institutional code and
5955: # institutional course code itself used for a LON-CAPA course.
5956: #
5957: # Formal Parameters:
5958: # $cmd - The command request that got us dispatched.
5959: # $tail - The tail of the command. In this case,
5960: # this is a colon separated string containing:
5961: # $dom - Course's LON-CAPA domain
5962: # $instcode - Institutional course code for the course
5963: # $inst_xlist - Institutional course Id for the crosslisting
5964: # $coowner - Username of co-owner
5965: # (values for all but $dom have been escaped).
5966: #
5967: # $client - Socket open on the client.
5968: # Returns:
5969: # 1 - Indicating processing should continue.
5970: #
5971: sub validate_instcrosslist_handler {
5972: my ($cmd, $tail, $client) = @_;
5973: my $userinput = "$cmd:$tail";
5974: my ($dom,$instcode,$inst_xlist,$coowner) = split(/:/,$tail);
5975: $instcode = &unescape($instcode);
5976: $inst_xlist = &unescape($inst_xlist);
5977: $coowner = &unescape($coowner);
5978: my $outcome = &localenroll::validate_crosslist_access($dom,$instcode,
5979: $inst_xlist,$coowner);
5980: &Reply($client, \$outcome, $userinput);
5981:
5982: return 1;
5983: }
5984: ®ister_handler("autovalidateinstcrosslist", \&validate_instcrosslist_handler, 0, 1, 0);
5985:
1.248 foxr 5986: # Get the official sections for which auto-enrollment is possible.
5987: # Since the admin people won't know about 'unofficial sections'
5988: # we cannot auto-enroll on them.
5989: # Formal Parameters:
5990: # $cmd - The command request that got us dispatched here.
5991: # $tail - The remainder of the request. In our case this
5992: # will be split into:
5993: # $coursecode - The course name from the admin point of view.
5994: # $cdom - The course's domain(?).
5995: # $client - Socket open on the client.
5996: # Returns:
5997: # 1 - Indiciting processing should continue.
5998: #
5999: sub get_sections_handler {
6000: my ($cmd, $tail, $client) = @_;
6001: my $userinput = "$cmd:$tail";
6002:
6003: my ($coursecode, $cdom) = split(/:/, $tail);
6004: my @secs = &localenroll::get_sections($coursecode,$cdom);
6005: my $seclist = &escape(join(':',@secs));
6006:
1.387 albertel 6007: &Reply($client, \$seclist, $userinput);
1.248 foxr 6008:
6009:
6010: return 1;
6011: }
6012: ®ister_handler("autogetsections", \&get_sections_handler, 0, 1, 0);
6013:
6014: # Validate the owner of a new course section.
6015: #
6016: # Formal Parameters:
6017: # $cmd - Command that got us dispatched.
6018: # $tail - the remainder of the command. For us this consists of a
6019: # colon separated string containing:
6020: # $inst - Course Id from the institutions point of view.
6021: # $owner - Proposed owner of the course.
6022: # $cdom - Domain of the course (from the institutions
6023: # point of view?)..
6024: # $client - Socket open on the client.
6025: #
6026: # Returns:
6027: # 1 - Processing should continue.
6028: #
6029: sub validate_course_owner_handler {
6030: my ($cmd, $tail, $client) = @_;
6031: my $userinput = "$cmd:$tail";
1.470 raeburn 6032: my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);
6033:
1.336 raeburn 6034: $owner = &unescape($owner);
1.470 raeburn 6035: $coowners = &unescape($coowners);
6036: my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
1.387 albertel 6037: &Reply($client, \$outcome, $userinput);
1.248 foxr 6038:
6039:
6040:
6041: return 1;
6042: }
6043: ®ister_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);
1.263 albertel 6044:
1.248 foxr 6045: #
6046: # Validate a course section in the official schedule of classes
6047: # from the institutions point of view (part of autoenrollment).
6048: #
6049: # Formal Parameters:
6050: # $cmd - The command request that got us dispatched.
6051: # $tail - The tail of the command. In this case,
6052: # this is a colon separated set of words that will be split
6053: # into:
6054: # $inst_course_id - The course/section id from the
6055: # institutions point of view.
6056: # $cdom - The domain from the institutions
6057: # point of view.
6058: # $client - Socket open on the client.
6059: # Returns:
6060: # 1 - Indicating processing should continue.
6061: #
6062: sub validate_course_section_handler {
6063: my ($cmd, $tail, $client) = @_;
6064: my $userinput = "$cmd:$tail";
6065: my ($inst_course_id, $cdom) = split(/:/, $tail);
6066:
6067: my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
1.387 albertel 6068: &Reply($client, \$outcome, $userinput);
1.248 foxr 6069:
6070:
6071: return 1;
6072: }
6073: ®ister_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);
6074:
6075: #
1.340 raeburn 6076: # Validate course owner's access to enrollment data for specific class section.
6077: #
6078: #
6079: # Formal Parameters:
6080: # $cmd - The command request that got us dispatched.
6081: # $tail - The tail of the command. In this case this is a colon separated
1.542 raeburn 6082: # set of values that will be split into:
1.340 raeburn 6083: # $inst_class - Institutional code for the specific class section
1.542 raeburn 6084: # $ownerlist - An escaped comma-separated list of username:domain
6085: # of the course owner, and co-owner(s).
1.340 raeburn 6086: # $cdom - The domain of the course from the institution's
6087: # point of view.
6088: # $client - The socket open on the client.
6089: # Returns:
6090: # 1 - continue processing.
6091: #
6092:
6093: sub validate_class_access_handler {
6094: my ($cmd, $tail, $client) = @_;
6095: my $userinput = "$cmd:$tail";
1.383 raeburn 6096: my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail);
1.392 raeburn 6097: my $owners = &unescape($ownerlist);
1.341 albertel 6098: my $outcome;
6099: eval {
6100: local($SIG{__DIE__})='DEFAULT';
1.392 raeburn 6101: $outcome=&localenroll::check_section($inst_class,$owners,$cdom);
1.341 albertel 6102: };
1.387 albertel 6103: &Reply($client,\$outcome, $userinput);
1.340 raeburn 6104:
6105: return 1;
6106: }
6107: ®ister_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);
6108:
6109: #
1.567 ! raeburn 6110: # Modify institutional sections (using customized &instsec_reformat()
! 6111: # routine in localenroll.pm), to either clutter or declutter, for
! 6112: # purposes of ensuring an institutional course section (string) can
! 6113: # be unambiguously separated into institutional course and section.
! 6114: #
! 6115: # Formal Parameters:
! 6116: # $cmd - The command request that got us dispatched.
! 6117: # $tail - The tail of the command. In this case this is a colon separated
! 6118: # set of values that will be split into:
! 6119: # $cdom - The LON-CAPA domain of the course.
! 6120: # $action - Either: clutter or declutter
! 6121: # clutter adds character(s) to eliminate ambiguity
! 6122: # declutter removes the added characters (e.g., for
! 6123: # display of the institutional course section string.
! 6124: # $info - A frozen hash in which keys are:
! 6125: # LON-CAPA course number:Institutional course code
! 6126: # and values are a reference to an array of the
! 6127: # items to modify -- either institutional sections,
! 6128: # or institutional course sections (for crosslistings).
! 6129: # $client - The socket open on the client.
! 6130: # Returns:
! 6131: # 1 - continue processing.
! 6132: #
! 6133:
! 6134: sub instsec_reformat_handler {
! 6135: my ($cmd, $tail, $client) = @_;
! 6136: my $userinput = "$cmd:$tail";
! 6137: my ($cdom,$action,$info) = split(/:/,$tail);
! 6138: my $instsecref = &Apache::lonnet::thaw_unescape($info);
! 6139: my ($outcome,$result);
! 6140: eval {
! 6141: local($SIG{__DIE__})='DEFAULT';
! 6142: $outcome=&localenroll::instsec_reformat($cdom,$action,$instsecref);
! 6143: if ($outcome eq 'ok') {
! 6144: if (ref($instsecref) eq 'HASH') {
! 6145: foreach my $key (keys(%{$instsecref})) {
! 6146: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($instsecref->{$key}).'&';
! 6147: }
! 6148: $result =~ s/\&$//;
! 6149: }
! 6150: }
! 6151: };
! 6152: if (!$@) {
! 6153: if ($outcome eq 'ok') {
! 6154: &Reply( $client, \$result, $userinput);
! 6155: } else {
! 6156: &Reply($client,\$outcome, $userinput);
! 6157: }
! 6158: } else {
! 6159: &Failure($client,"unknown_cmd\n",$userinput);
! 6160: }
! 6161: return 1;
! 6162: }
! 6163: ®ister_handler("autoinstsecreformat",\&instsec_reformat_handler, 0, 1, 0);
! 6164:
! 6165: #
1.542 raeburn 6166: # Validate course owner or co-owners(s) access to enrollment data for all sections
6167: # and crosslistings for a particular course.
6168: #
6169: #
6170: # Formal Parameters:
6171: # $cmd - The command request that got us dispatched.
6172: # $tail - The tail of the command. In this case this is a colon separated
6173: # set of values that will be split into:
6174: # $ownerlist - An escaped comma-separated list of username:domain
6175: # of the course owner, and co-owner(s).
6176: # $cdom - The domain of the course from the institution's
6177: # point of view.
6178: # $classes - Frozen hash of institutional course sections and
6179: # crosslistings.
6180: # $client - The socket open on the client.
6181: # Returns:
6182: # 1 - continue processing.
6183: #
6184:
6185: sub validate_classes_handler {
6186: my ($cmd, $tail, $client) = @_;
6187: my $userinput = "$cmd:$tail";
6188: my ($ownerlist,$cdom,$classes) = split(/:/, $tail);
6189: my $classesref = &Apache::lonnet::thaw_unescape($classes);
6190: my $owners = &unescape($ownerlist);
6191: my $result;
6192: eval {
6193: local($SIG{__DIE__})='DEFAULT';
6194: my %validations;
6195: my $response = &localenroll::check_instclasses($owners,$cdom,$classesref,
6196: \%validations);
6197: if ($response eq 'ok') {
6198: foreach my $key (keys(%validations)) {
6199: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&';
6200: }
6201: $result =~ s/\&$//;
6202: } else {
6203: $result = 'error';
6204: }
6205: };
6206: if (!$@) {
6207: &Reply($client, \$result, $userinput);
6208: } else {
6209: &Failure($client,"unknown_cmd\n",$userinput);
6210: }
6211: return 1;
6212: }
6213: ®ister_handler("autovalidateinstclasses", \&validate_classes_handler, 0, 1, 0);
6214:
6215: #
1.340 raeburn 6216: # Create a password for a new LON-CAPA user added by auto-enrollment.
6217: # Only used for case where authentication method for new user is localauth
1.248 foxr 6218: #
6219: # Formal Parameters:
6220: # $cmd - The command request that got us dispatched.
6221: # $tail - The tail of the command. In this case this is a colon separated
6222: # set of words that will be split into:
1.340 raeburn 6223: # $authparam - An authentication parameter (localauth parameter).
1.248 foxr 6224: # $cdom - The domain of the course from the institution's
6225: # point of view.
6226: # $client - The socket open on the client.
6227: # Returns:
6228: # 1 - continue processing.
6229: #
6230: sub create_auto_enroll_password_handler {
6231: my ($cmd, $tail, $client) = @_;
6232: my $userinput = "$cmd:$tail";
6233:
6234: my ($authparam, $cdom) = split(/:/, $userinput);
6235:
6236: my ($create_passwd,$authchk);
6237: ($authparam,
6238: $create_passwd,
6239: $authchk) = &localenroll::create_password($authparam,$cdom);
6240:
6241: &Reply($client, &escape($authparam.':'.$create_passwd.':'.$authchk)."\n",
6242: $userinput);
6243:
6244:
6245: return 1;
6246: }
6247: ®ister_handler("autocreatepassword", \&create_auto_enroll_password_handler,
6248: 0, 1, 0);
6249:
1.522 raeburn 6250: sub auto_export_grades_handler {
6251: my ($cmd, $tail, $client) = @_;
6252: my $userinput = "$cmd:$tail";
6253: my ($cdom,$cnum,$info,$data) = split(/:/,$tail);
6254: my $inforef = &Apache::lonnet::thaw_unescape($info);
6255: my $dataref = &Apache::lonnet::thaw_unescape($data);
6256: my ($outcome,$result);;
6257: eval {
6258: local($SIG{__DIE__})='DEFAULT';
6259: my %rtnhash;
6260: $outcome=&localenroll::export_grades($cdom,$cnum,$inforef,$dataref,\%rtnhash);
6261: if ($outcome eq 'ok') {
6262: foreach my $key (keys(%rtnhash)) {
6263: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rtnhash{$key}).'&';
6264: }
6265: $result =~ s/\&$//;
6266: }
6267: };
6268: if (!$@) {
6269: if ($outcome eq 'ok') {
6270: if ($cipher) {
6271: my $cmdlength=length($result);
6272: $result.=" ";
6273: my $encresult='';
6274: for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
6275: $encresult.= unpack("H16",
6276: $cipher->encrypt(substr($result,
6277: $encidx,
6278: 8)));
6279: }
6280: &Reply( $client, "enc:$cmdlength:$encresult\n", $userinput);
6281: } else {
6282: &Failure( $client, "error:no_key\n", $userinput);
6283: }
6284: } else {
6285: &Reply($client, "$outcome\n", $userinput);
6286: }
6287: } else {
6288: &Failure($client,"export_error\n",$userinput);
6289: }
6290: return 1;
6291: }
6292: ®ister_handler("autoexportgrades", \&auto_export_grades_handler,
1.536 raeburn 6293: 1, 1, 0);
1.522 raeburn 6294:
1.248 foxr 6295: # Retrieve and remove temporary files created by/during autoenrollment.
6296: #
6297: # Formal Parameters:
6298: # $cmd - The command that got us dispatched.
6299: # $tail - The tail of the command. In our case this is a colon
6300: # separated list that will be split into:
1.526 raeburn 6301: # $filename - The name of the file to retrieve.
1.248 foxr 6302: # The filename is given as a path relative to
6303: # the LonCAPA temp file directory.
6304: # $client - Socket open on the client.
6305: #
6306: # Returns:
6307: # 1 - Continue processing.
6308: sub retrieve_auto_file_handler {
6309: my ($cmd, $tail, $client) = @_;
6310: my $userinput = "cmd:$tail";
6311:
6312: my ($filename) = split(/:/, $tail);
6313:
6314: my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
1.521 raeburn 6315:
6316: if ($filename =~m{/\.\./}) {
6317: &Failure($client, "refused\n", $userinput);
1.526 raeburn 6318: } elsif ($filename !~ /^$LONCAPA::match_domain\_$LONCAPA::match_courseid\_.+_classlist\.xml$/) {
6319: &Failure($client, "refused\n", $userinput);
1.521 raeburn 6320: } elsif ( (-e $source) && ($filename ne '') ) {
1.248 foxr 6321: my $reply = '';
6322: if (open(my $fh,$source)) {
6323: while (<$fh>) {
6324: chomp($_);
6325: $_ =~ s/^\s+//g;
6326: $_ =~ s/\s+$//g;
6327: $reply .= $_;
6328: }
6329: close($fh);
6330: &Reply($client, &escape($reply)."\n", $userinput);
6331:
6332: # Does this have to be uncommented??!? (RF).
6333: #
6334: # unlink($source);
6335: } else {
6336: &Failure($client, "error\n", $userinput);
6337: }
6338: } else {
6339: &Failure($client, "error\n", $userinput);
6340: }
6341:
6342:
6343: return 1;
6344: }
6345: ®ister_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);
6346:
1.423 raeburn 6347: sub crsreq_checks_handler {
6348: my ($cmd, $tail, $client) = @_;
6349: my $userinput = "$cmd:$tail";
6350: my $dom = $tail;
6351: my $result;
1.519 raeburn 6352: my @reqtypes = ('official','unofficial','community','textbook','placement');
1.423 raeburn 6353: eval {
6354: local($SIG{__DIE__})='DEFAULT';
6355: my %validations;
1.424 raeburn 6356: my $response = &localenroll::crsreq_checks($dom,\@reqtypes,
6357: \%validations);
1.423 raeburn 6358: if ($response eq 'ok') {
6359: foreach my $key (keys(%validations)) {
6360: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&';
6361: }
6362: $result =~ s/\&$//;
6363: } else {
6364: $result = 'error';
6365: }
6366: };
6367: if (!$@) {
6368: &Reply($client, \$result, $userinput);
6369: } else {
6370: &Failure($client,"unknown_cmd\n",$userinput);
6371: }
6372: return 1;
6373: }
6374: ®ister_handler("autocrsreqchecks", \&crsreq_checks_handler, 0, 1, 0);
6375:
6376: sub validate_crsreq_handler {
6377: my ($cmd, $tail, $client) = @_;
6378: my $userinput = "$cmd:$tail";
1.508 raeburn 6379: my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$customdata) = split(/:/, $tail);
1.423 raeburn 6380: $instcode = &unescape($instcode);
6381: $owner = &unescape($owner);
6382: $crstype = &unescape($crstype);
6383: $inststatuslist = &unescape($inststatuslist);
6384: $instcode = &unescape($instcode);
6385: $instseclist = &unescape($instseclist);
1.508 raeburn 6386: my $custominfo = &Apache::lonnet::thaw_unescape($customdata);
1.423 raeburn 6387: my $outcome;
6388: eval {
6389: local($SIG{__DIE__})='DEFAULT';
6390: $outcome = &localenroll::validate_crsreq($dom,$owner,$crstype,
6391: $inststatuslist,$instcode,
1.508 raeburn 6392: $instseclist,$custominfo);
1.423 raeburn 6393: };
6394: if (!$@) {
6395: &Reply($client, \$outcome, $userinput);
6396: } else {
6397: &Failure($client,"unknown_cmd\n",$userinput);
6398: }
6399: return 1;
6400: }
6401: ®ister_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0);
6402:
1.506 raeburn 6403: sub crsreq_update_handler {
6404: my ($cmd, $tail, $client) = @_;
6405: my $userinput = "$cmd:$tail";
1.509 raeburn 6406: my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,$code,
6407: $accessstart,$accessend,$infohashref) =
1.506 raeburn 6408: split(/:/, $tail);
6409: $crstype = &unescape($crstype);
6410: $action = &unescape($action);
6411: $ownername = &unescape($ownername);
6412: $ownerdomain = &unescape($ownerdomain);
6413: $fullname = &unescape($fullname);
6414: $title = &unescape($title);
6415: $code = &unescape($code);
1.509 raeburn 6416: $accessstart = &unescape($accessstart);
6417: $accessend = &unescape($accessend);
1.506 raeburn 6418: my $incoming = &Apache::lonnet::thaw_unescape($infohashref);
6419: my ($result,$outcome);
6420: eval {
6421: local($SIG{__DIE__})='DEFAULT';
6422: my %rtnhash;
6423: $outcome = &localenroll::crsreq_updates($cdom,$cnum,$crstype,$action,
6424: $ownername,$ownerdomain,$fullname,
1.509 raeburn 6425: $title,$code,$accessstart,$accessend,
6426: $incoming,\%rtnhash);
1.506 raeburn 6427: if ($outcome eq 'ok') {
1.515 raeburn 6428: my @posskeys = qw(createdweb createdmsg createdcustomized createdactions queuedweb queuedmsg formitems reviewweb validationjs onload javascript);
1.506 raeburn 6429: foreach my $key (keys(%rtnhash)) {
6430: if (grep(/^\Q$key\E/,@posskeys)) {
6431: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rtnhash{$key}).'&';
6432: }
6433: }
6434: $result =~ s/\&$//;
6435: }
6436: };
6437: if (!$@) {
6438: if ($outcome eq 'ok') {
6439: &Reply($client, \$result, $userinput);
6440: } else {
6441: &Reply($client, "format_error\n", $userinput);
6442: }
6443: } else {
6444: &Failure($client,"unknown_cmd\n",$userinput);
6445: }
6446: return 1;
6447: }
6448: ®ister_handler("autocrsrequpdate", \&crsreq_update_handler, 0, 1, 0);
6449:
1.248 foxr 6450: #
6451: # Read and retrieve institutional code format (for support form).
6452: # Formal Parameters:
6453: # $cmd - Command that dispatched us.
6454: # $tail - Tail of the command. In this case it conatins
6455: # the course domain and the coursename.
6456: # $client - Socket open on the client.
6457: # Returns:
6458: # 1 - Continue processing.
6459: #
6460: sub get_institutional_code_format_handler {
6461: my ($cmd, $tail, $client) = @_;
6462: my $userinput = "$cmd:$tail";
6463:
6464: my $reply;
6465: my($cdom,$course) = split(/:/,$tail);
6466: my @pairs = split/\&/,$course;
6467: my %instcodes = ();
6468: my %codes = ();
6469: my @codetitles = ();
6470: my %cat_titles = ();
6471: my %cat_order = ();
6472: foreach (@pairs) {
6473: my ($key,$value) = split/=/,$_;
6474: $instcodes{&unescape($key)} = &unescape($value);
6475: }
6476: my $formatreply = &localenroll::instcode_format($cdom,
6477: \%instcodes,
6478: \%codes,
6479: \@codetitles,
6480: \%cat_titles,
6481: \%cat_order);
6482: if ($formatreply eq 'ok') {
1.365 albertel 6483: my $codes_str = &Apache::lonnet::hash2str(%codes);
6484: my $codetitles_str = &Apache::lonnet::array2str(@codetitles);
6485: my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles);
6486: my $cat_order_str = &Apache::lonnet::hash2str(%cat_order);
1.248 foxr 6487: &Reply($client,
6488: $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
6489: .$cat_order_str."\n",
6490: $userinput);
6491: } else {
6492: # this else branch added by RF since if not ok, lonc will
6493: # hang waiting on reply until timeout.
6494: #
6495: &Reply($client, "format_error\n", $userinput);
6496: }
6497:
6498: return 1;
6499: }
1.265 albertel 6500: ®ister_handler("autoinstcodeformat",
6501: \&get_institutional_code_format_handler,0,1,0);
1.246 foxr 6502:
1.345 raeburn 6503: sub get_institutional_defaults_handler {
6504: my ($cmd, $tail, $client) = @_;
6505: my $userinput = "$cmd:$tail";
6506:
6507: my $dom = $tail;
6508: my %defaults_hash;
6509: my @code_order;
6510: my $outcome;
6511: eval {
6512: local($SIG{__DIE__})='DEFAULT';
6513: $outcome = &localenroll::instcode_defaults($dom,\%defaults_hash,
6514: \@code_order);
6515: };
6516: if (!$@) {
6517: if ($outcome eq 'ok') {
6518: my $result='';
6519: while (my ($key,$value) = each(%defaults_hash)) {
6520: $result.=&escape($key).'='.&escape($value).'&';
6521: }
6522: $result .= 'code_order='.&escape(join('&',@code_order));
1.387 albertel 6523: &Reply($client,\$result,$userinput);
1.345 raeburn 6524: } else {
6525: &Reply($client,"error\n", $userinput);
6526: }
6527: } else {
6528: &Failure($client,"unknown_cmd\n",$userinput);
6529: }
6530: }
6531: ®ister_handler("autoinstcodedefaults",
6532: \&get_institutional_defaults_handler,0,1,0);
6533:
1.416 raeburn 6534: sub get_possible_instcodes_handler {
6535: my ($cmd, $tail, $client) = @_;
6536: my $userinput = "$cmd:$tail";
6537:
6538: my $reply;
6539: my $cdom = $tail;
1.417 raeburn 6540: my (@codetitles,%cat_titles,%cat_order,@code_order);
1.416 raeburn 6541: my $formatreply = &localenroll::possible_instcodes($cdom,
6542: \@codetitles,
6543: \%cat_titles,
1.417 raeburn 6544: \%cat_order,
6545: \@code_order);
1.416 raeburn 6546: if ($formatreply eq 'ok') {
6547: my $result = join('&',map {&escape($_);} (@codetitles)).':';
1.417 raeburn 6548: $result .= join('&',map {&escape($_);} (@code_order)).':';
1.416 raeburn 6549: foreach my $key (keys(%cat_titles)) {
6550: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_titles{$key}).'&';
6551: }
6552: $result =~ s/\&$//;
6553: $result .= ':';
6554: foreach my $key (keys(%cat_order)) {
6555: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_order{$key}).'&';
6556: }
6557: $result =~ s/\&$//;
6558: &Reply($client,\$result,$userinput);
6559: } else {
6560: &Reply($client, "format_error\n", $userinput);
6561: }
6562: return 1;
6563: }
6564: ®ister_handler("autopossibleinstcodes",
6565: \&get_possible_instcodes_handler,0,1,0);
6566:
1.381 raeburn 6567: sub get_institutional_user_rules {
6568: my ($cmd, $tail, $client) = @_;
6569: my $userinput = "$cmd:$tail";
6570: my $dom = &unescape($tail);
6571: my (%rules_hash,@rules_order);
6572: my $outcome;
6573: eval {
6574: local($SIG{__DIE__})='DEFAULT';
6575: $outcome = &localenroll::username_rules($dom,\%rules_hash,\@rules_order);
6576: };
6577: if (!$@) {
6578: if ($outcome eq 'ok') {
6579: my $result;
6580: foreach my $key (keys(%rules_hash)) {
6581: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
6582: }
6583: $result =~ s/\&$//;
6584: $result .= ':';
6585: if (@rules_order > 0) {
6586: foreach my $item (@rules_order) {
6587: $result .= &escape($item).'&';
6588: }
6589: }
6590: $result =~ s/\&$//;
1.387 albertel 6591: &Reply($client,\$result,$userinput);
1.381 raeburn 6592: } else {
6593: &Reply($client,"error\n", $userinput);
6594: }
6595: } else {
6596: &Failure($client,"unknown_cmd\n",$userinput);
6597: }
6598: }
6599: ®ister_handler("instuserrules",\&get_institutional_user_rules,0,1,0);
6600:
1.389 raeburn 6601: sub get_institutional_id_rules {
6602: my ($cmd, $tail, $client) = @_;
6603: my $userinput = "$cmd:$tail";
6604: my $dom = &unescape($tail);
6605: my (%rules_hash,@rules_order);
6606: my $outcome;
6607: eval {
6608: local($SIG{__DIE__})='DEFAULT';
6609: $outcome = &localenroll::id_rules($dom,\%rules_hash,\@rules_order);
6610: };
6611: if (!$@) {
6612: if ($outcome eq 'ok') {
6613: my $result;
6614: foreach my $key (keys(%rules_hash)) {
6615: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
6616: }
6617: $result =~ s/\&$//;
6618: $result .= ':';
6619: if (@rules_order > 0) {
6620: foreach my $item (@rules_order) {
6621: $result .= &escape($item).'&';
6622: }
6623: }
6624: $result =~ s/\&$//;
6625: &Reply($client,\$result,$userinput);
6626: } else {
6627: &Reply($client,"error\n", $userinput);
6628: }
6629: } else {
6630: &Failure($client,"unknown_cmd\n",$userinput);
6631: }
6632: }
6633: ®ister_handler("instidrules",\&get_institutional_id_rules,0,1,0);
6634:
1.397 raeburn 6635: sub get_institutional_selfcreate_rules {
1.396 raeburn 6636: my ($cmd, $tail, $client) = @_;
6637: my $userinput = "$cmd:$tail";
6638: my $dom = &unescape($tail);
6639: my (%rules_hash,@rules_order);
6640: my $outcome;
6641: eval {
6642: local($SIG{__DIE__})='DEFAULT';
1.397 raeburn 6643: $outcome = &localenroll::selfcreate_rules($dom,\%rules_hash,\@rules_order);
1.396 raeburn 6644: };
6645: if (!$@) {
6646: if ($outcome eq 'ok') {
6647: my $result;
6648: foreach my $key (keys(%rules_hash)) {
6649: $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
6650: }
6651: $result =~ s/\&$//;
6652: $result .= ':';
6653: if (@rules_order > 0) {
6654: foreach my $item (@rules_order) {
6655: $result .= &escape($item).'&';
6656: }
6657: }
6658: $result =~ s/\&$//;
6659: &Reply($client,\$result,$userinput);
6660: } else {
6661: &Reply($client,"error\n", $userinput);
6662: }
6663: } else {
6664: &Failure($client,"unknown_cmd\n",$userinput);
6665: }
6666: }
1.397 raeburn 6667: ®ister_handler("instemailrules",\&get_institutional_selfcreate_rules,0,1,0);
1.396 raeburn 6668:
1.381 raeburn 6669:
6670: sub institutional_username_check {
6671: my ($cmd, $tail, $client) = @_;
6672: my $userinput = "$cmd:$tail";
6673: my %rulecheck;
6674: my $outcome;
6675: my ($udom,$uname,@rules) = split(/:/,$tail);
6676: $udom = &unescape($udom);
6677: $uname = &unescape($uname);
6678: @rules = map {&unescape($_);} (@rules);
6679: eval {
6680: local($SIG{__DIE__})='DEFAULT';
6681: $outcome = &localenroll::username_check($udom,$uname,\@rules,\%rulecheck);
6682: };
6683: if (!$@) {
6684: if ($outcome eq 'ok') {
6685: my $result='';
6686: foreach my $key (keys(%rulecheck)) {
6687: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
6688: }
1.387 albertel 6689: &Reply($client,\$result,$userinput);
1.381 raeburn 6690: } else {
6691: &Reply($client,"error\n", $userinput);
6692: }
6693: } else {
6694: &Failure($client,"unknown_cmd\n",$userinput);
6695: }
6696: }
6697: ®ister_handler("instrulecheck",\&institutional_username_check,0,1,0);
6698:
1.389 raeburn 6699: sub institutional_id_check {
6700: my ($cmd, $tail, $client) = @_;
6701: my $userinput = "$cmd:$tail";
6702: my %rulecheck;
6703: my $outcome;
6704: my ($udom,$id,@rules) = split(/:/,$tail);
6705: $udom = &unescape($udom);
6706: $id = &unescape($id);
6707: @rules = map {&unescape($_);} (@rules);
6708: eval {
6709: local($SIG{__DIE__})='DEFAULT';
6710: $outcome = &localenroll::id_check($udom,$id,\@rules,\%rulecheck);
6711: };
6712: if (!$@) {
6713: if ($outcome eq 'ok') {
6714: my $result='';
6715: foreach my $key (keys(%rulecheck)) {
6716: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
6717: }
6718: &Reply($client,\$result,$userinput);
6719: } else {
6720: &Reply($client,"error\n", $userinput);
6721: }
6722: } else {
6723: &Failure($client,"unknown_cmd\n",$userinput);
6724: }
6725: }
6726: ®ister_handler("instidrulecheck",\&institutional_id_check,0,1,0);
1.345 raeburn 6727:
1.397 raeburn 6728: sub institutional_selfcreate_check {
1.396 raeburn 6729: my ($cmd, $tail, $client) = @_;
6730: my $userinput = "$cmd:$tail";
6731: my %rulecheck;
6732: my $outcome;
6733: my ($udom,$email,@rules) = split(/:/,$tail);
6734: $udom = &unescape($udom);
6735: $email = &unescape($email);
6736: @rules = map {&unescape($_);} (@rules);
6737: eval {
6738: local($SIG{__DIE__})='DEFAULT';
1.397 raeburn 6739: $outcome = &localenroll::selfcreate_check($udom,$email,\@rules,\%rulecheck);
1.396 raeburn 6740: };
6741: if (!$@) {
6742: if ($outcome eq 'ok') {
6743: my $result='';
6744: foreach my $key (keys(%rulecheck)) {
6745: $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
6746: }
6747: &Reply($client,\$result,$userinput);
6748: } else {
6749: &Reply($client,"error\n", $userinput);
6750: }
6751: } else {
6752: &Failure($client,"unknown_cmd\n",$userinput);
6753: }
6754: }
1.397 raeburn 6755: ®ister_handler("instselfcreatecheck",\&institutional_selfcreate_check,0,1,0);
1.396 raeburn 6756:
1.317 raeburn 6757: # Get domain specific conditions for import of student photographs to a course
6758: #
6759: # Retrieves information from photo_permission subroutine in localenroll.
6760: # Returns outcome (ok) if no processing errors, and whether course owner is
6761: # required to accept conditions of use (yes/no).
6762: #
6763: #
6764: sub photo_permission_handler {
6765: my ($cmd, $tail, $client) = @_;
6766: my $userinput = "$cmd:$tail";
6767: my $cdom = $tail;
6768: my ($perm_reqd,$conditions);
1.320 albertel 6769: my $outcome;
6770: eval {
6771: local($SIG{__DIE__})='DEFAULT';
6772: $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
6773: \$conditions);
6774: };
6775: if (!$@) {
6776: &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
6777: $userinput);
6778: } else {
6779: &Failure($client,"unknown_cmd\n",$userinput);
6780: }
6781: return 1;
1.317 raeburn 6782: }
6783: ®ister_handler("autophotopermission",\&photo_permission_handler,0,1,0);
6784:
6785: #
6786: # Checks if student photo is available for a user in the domain, in the user's
6787: # directory (in /userfiles/internal/studentphoto.jpg).
6788: # Uses localstudentphoto:fetch() to ensure there is an up to date copy of
6789: # the student's photo.
6790:
6791: sub photo_check_handler {
6792: my ($cmd, $tail, $client) = @_;
6793: my $userinput = "$cmd:$tail";
6794: my ($udom,$uname,$pid) = split(/:/,$tail);
6795: $udom = &unescape($udom);
6796: $uname = &unescape($uname);
6797: $pid = &unescape($pid);
6798: my $path=&propath($udom,$uname).'/userfiles/internal/';
6799: if (!-e $path) {
6800: &mkpath($path);
6801: }
6802: my $response;
6803: my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
6804: $result .= ':'.$response;
6805: &Reply($client, &escape($result)."\n",$userinput);
1.320 albertel 6806: return 1;
1.317 raeburn 6807: }
6808: ®ister_handler("autophotocheck",\&photo_check_handler,0,1,0);
6809:
6810: #
6811: # Retrieve information from localenroll about whether to provide a button
6812: # for users who have enbled import of student photos to initiate an
6813: # update of photo files for registered students. Also include
6814: # comment to display alongside button.
6815:
6816: sub photo_choice_handler {
6817: my ($cmd, $tail, $client) = @_;
6818: my $userinput = "$cmd:$tail";
6819: my $cdom = &unescape($tail);
1.320 albertel 6820: my ($update,$comment);
6821: eval {
6822: local($SIG{__DIE__})='DEFAULT';
6823: ($update,$comment) = &localenroll::manager_photo_update($cdom);
6824: };
6825: if (!$@) {
6826: &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
6827: } else {
6828: &Failure($client,"unknown_cmd\n",$userinput);
6829: }
6830: return 1;
1.317 raeburn 6831: }
6832: ®ister_handler("autophotochoice",\&photo_choice_handler,0,1,0);
6833:
1.265 albertel 6834: #
6835: # Gets a student's photo to exist (in the correct image type) in the user's
6836: # directory.
6837: # Formal Parameters:
6838: # $cmd - The command request that got us dispatched.
6839: # $tail - A colon separated set of words that will be split into:
6840: # $domain - student's domain
6841: # $uname - student username
6842: # $type - image type desired
6843: # $client - The socket open on the client.
6844: # Returns:
6845: # 1 - continue processing.
1.317 raeburn 6846:
1.265 albertel 6847: sub student_photo_handler {
6848: my ($cmd, $tail, $client) = @_;
1.317 raeburn 6849: my ($domain,$uname,$ext,$type) = split(/:/, $tail);
1.265 albertel 6850:
1.317 raeburn 6851: my $path=&propath($domain,$uname). '/userfiles/internal/';
6852: my $filename = 'studentphoto.'.$ext;
6853: if ($type eq 'thumbnail') {
6854: $filename = 'studentphoto_tn.'.$ext;
6855: }
6856: if (-e $path.$filename) {
1.265 albertel 6857: &Reply($client,"ok\n","$cmd:$tail");
6858: return 1;
6859: }
6860: &mkpath($path);
1.317 raeburn 6861: my $file;
6862: if ($type eq 'thumbnail') {
1.320 albertel 6863: eval {
6864: local($SIG{__DIE__})='DEFAULT';
6865: $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
6866: };
1.317 raeburn 6867: } else {
6868: $file=&localstudentphoto::fetch($domain,$uname);
6869: }
1.265 albertel 6870: if (!$file) {
6871: &Failure($client,"unavailable\n","$cmd:$tail");
6872: return 1;
6873: }
1.317 raeburn 6874: if (!-e $path.$filename) { &convert_photo($file,$path.$filename); }
6875: if (-e $path.$filename) {
1.265 albertel 6876: &Reply($client,"ok\n","$cmd:$tail");
6877: return 1;
6878: }
6879: &Failure($client,"unable_to_convert\n","$cmd:$tail");
6880: return 1;
6881: }
6882: ®ister_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
1.246 foxr 6883:
1.361 raeburn 6884: sub inst_usertypes_handler {
6885: my ($cmd, $domain, $client) = @_;
6886: my $res;
6887: my $userinput = $cmd.":".$domain; # For logging purposes.
1.370 albertel 6888: my (%typeshash,@order,$result);
6889: eval {
6890: local($SIG{__DIE__})='DEFAULT';
6891: $result=&localenroll::inst_usertypes($domain,\%typeshash,\@order);
6892: };
6893: if ($result eq 'ok') {
1.361 raeburn 6894: if (keys(%typeshash) > 0) {
6895: foreach my $key (keys(%typeshash)) {
6896: $res.=&escape($key).'='.&escape($typeshash{$key}).'&';
6897: }
6898: }
6899: $res=~s/\&$//;
6900: $res .= ':';
6901: if (@order > 0) {
6902: foreach my $item (@order) {
6903: $res .= &escape($item).'&';
6904: }
6905: }
6906: $res=~s/\&$//;
6907: }
1.387 albertel 6908: &Reply($client, \$res, $userinput);
1.361 raeburn 6909: return 1;
6910: }
6911: ®ister_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);
6912:
1.264 albertel 6913: # mkpath makes all directories for a file, expects an absolute path with a
6914: # file or a trailing / if just a dir is passed
6915: # returns 1 on success 0 on failure
6916: sub mkpath {
6917: my ($file)=@_;
6918: my @parts=split(/\//,$file,-1);
6919: my $now=$parts[0].'/'.$parts[1].'/'.$parts[2];
6920: for (my $i=3;$i<= ($#parts-1);$i++) {
1.265 albertel 6921: $now.='/'.$parts[$i];
1.264 albertel 6922: if (!-e $now) {
6923: if (!mkdir($now,0770)) { return 0; }
6924: }
6925: }
6926: return 1;
6927: }
6928:
1.207 foxr 6929: #---------------------------------------------------------------
6930: #
6931: # Getting, decoding and dispatching requests:
6932: #
6933: #
6934: # Get a Request:
6935: # Gets a Request message from the client. The transaction
6936: # is defined as a 'line' of text. We remove the new line
6937: # from the text line.
1.226 foxr 6938: #
1.211 albertel 6939: sub get_request {
1.207 foxr 6940: my $input = <$client>;
6941: chomp($input);
1.226 foxr 6942:
1.234 foxr 6943: &Debug("get_request: Request = $input\n");
1.207 foxr 6944:
6945: &status('Processing '.$clientname.':'.$input);
6946:
6947: return $input;
6948: }
1.212 foxr 6949: #---------------------------------------------------------------
6950: #
6951: # Process a request. This sub should shrink as each action
6952: # gets farmed out into a separat sub that is registered
6953: # with the dispatch hash.
6954: #
6955: # Parameters:
6956: # user_input - The request received from the client (lonc).
1.525 raeburn 6957: #
1.212 foxr 6958: # Returns:
6959: # true to keep processing, false if caller should exit.
6960: #
6961: sub process_request {
1.525 raeburn 6962: my ($userinput) = @_; # Easier for now to break style than to
6963: # fix all the userinput -> user_input.
1.212 foxr 6964: my $wasenc = 0; # True if request was encrypted.
6965: # ------------------------------------------------------------ See if encrypted
1.322 albertel 6966: # for command
6967: # sethost:<server>
6968: # <command>:<args>
6969: # we just send it to the processor
6970: # for
6971: # sethost:<server>:<command>:<args>
6972: # we do the implict set host and then do the command
6973: if ($userinput =~ /^sethost:/) {
6974: (my $cmd,my $newid,$userinput) = split(':',$userinput,3);
6975: if (defined($userinput)) {
6976: &sethost("$cmd:$newid");
6977: } else {
6978: $userinput = "$cmd:$newid";
6979: }
6980: }
6981:
1.212 foxr 6982: if ($userinput =~ /^enc/) {
6983: $userinput = decipher($userinput);
6984: $wasenc=1;
6985: if(!$userinput) { # Cipher not defined.
1.251 foxr 6986: &Failure($client, "error: Encrypted data without negotated key\n");
1.212 foxr 6987: return 0;
6988: }
6989: }
6990: Debug("process_request: $userinput\n");
6991:
1.213 foxr 6992: #
6993: # The 'correct way' to add a command to lond is now to
6994: # write a sub to execute it and Add it to the command dispatch
6995: # hash via a call to register_handler.. The comments to that
6996: # sub should give you enough to go on to show how to do this
6997: # along with the examples that are building up as this code
6998: # is getting refactored. Until all branches of the
6999: # if/elseif monster below have been factored out into
7000: # separate procesor subs, if the dispatch hash is missing
7001: # the command keyword, we will fall through to the remainder
7002: # of the if/else chain below in order to keep this thing in
7003: # working order throughout the transmogrification.
7004:
7005: my ($command, $tail) = split(/:/, $userinput, 2);
7006: chomp($command);
7007: chomp($tail);
7008: $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.
1.214 foxr 7009: $command =~ s/(\r)//; # And this too for parameterless commands.
7010: if(!$tail) {
7011: $tail =""; # defined but blank.
7012: }
1.213 foxr 7013:
7014: &Debug("Command received: $command, encoded = $wasenc");
7015:
7016: if(defined $Dispatcher{$command}) {
7017:
7018: my $dispatch_info = $Dispatcher{$command};
7019: my $handler = $$dispatch_info[0];
7020: my $need_encode = $$dispatch_info[1];
7021: my $client_types = $$dispatch_info[2];
7022: Debug("Matched dispatch hash: mustencode: $need_encode "
7023: ."ClientType $client_types");
7024:
7025: # Validate the request:
7026:
7027: my $ok = 1;
7028: my $requesterprivs = 0;
7029: if(&isClient()) {
7030: $requesterprivs |= $CLIENT_OK;
7031: }
7032: if(&isManager()) {
7033: $requesterprivs |= $MANAGER_OK;
7034: }
7035: if($need_encode && (!$wasenc)) {
7036: Debug("Must encode but wasn't: $need_encode $wasenc");
7037: $ok = 0;
7038: }
7039: if(($client_types & $requesterprivs) == 0) {
7040: Debug("Client not privileged to do this operation");
7041: $ok = 0;
7042: }
1.525 raeburn 7043: if ($ok) {
1.535 raeburn 7044: my $realcommand = $command;
7045: if ($command eq 'querysend') {
7046: my ($query,$rest)=split(/\:/,$tail,2);
7047: $query=~s/\n*$//g;
7048: my @possqueries =
7049: qw(userlog courselog fetchenrollment institutionalphotos usersearch instdirsearch getinstuser getmultinstusers);
7050: if (grep(/^\Q$query\E$/,@possqueries)) {
7051: $command .= '_'.$query;
7052: } elsif ($query eq 'prepare activity log') {
7053: $command .= '_activitylog';
7054: }
7055: }
1.525 raeburn 7056: if (ref($trust{$command}) eq 'HASH') {
7057: my $donechecks;
7058: if ($trust{$command}{'anywhere'}) {
7059: $donechecks = 1;
7060: } elsif ($trust{$command}{'manageronly'}) {
7061: unless (&isManager()) {
7062: $ok = 0;
7063: }
7064: $donechecks = 1;
7065: } elsif ($trust{$command}{'institutiononly'}) {
7066: unless ($clientsameinst) {
7067: $ok = 0;
7068: }
7069: $donechecks = 1;
7070: } elsif ($clientsameinst) {
7071: $donechecks = 1;
7072: }
7073: unless ($donechecks) {
7074: foreach my $rule (keys(%{$trust{$command}})) {
7075: next if ($rule eq 'remote');
7076: if ($trust{$command}{$rule}) {
7077: if ($clientprohibited{$rule}) {
7078: $ok = 0;
7079: } else {
7080: $ok = 1;
7081: $donechecks = 1;
7082: last;
7083: }
7084: }
7085: }
7086: }
7087: unless ($donechecks) {
7088: if ($trust{$command}{'remote'}) {
7089: if ($clientremoteok) {
7090: $ok = 1;
7091: } else {
7092: $ok = 0;
7093: }
7094: }
7095: }
7096: }
1.535 raeburn 7097: $command = $realcommand;
1.525 raeburn 7098: }
1.213 foxr 7099:
7100: if($ok) {
7101: Debug("Dispatching to handler $command $tail");
7102: my $keep_going = &$handler($command, $tail, $client);
7103: return $keep_going;
7104: } else {
7105: Debug("Refusing to dispatch because client did not match requirements");
7106: Failure($client, "refused\n", $userinput);
7107: return 1;
7108: }
1.525 raeburn 7109: }
1.213 foxr 7110:
1.262 foxr 7111: print $client "unknown_cmd\n";
1.212 foxr 7112: # -------------------------------------------------------------------- complete
7113: Debug("process_request - returning 1");
7114: return 1;
7115: }
1.207 foxr 7116: #
7117: # Decipher encoded traffic
7118: # Parameters:
7119: # input - Encoded data.
7120: # Returns:
7121: # Decoded data or undef if encryption key was not yet negotiated.
7122: # Implicit input:
7123: # cipher - This global holds the negotiated encryption key.
7124: #
1.211 albertel 7125: sub decipher {
1.207 foxr 7126: my ($input) = @_;
7127: my $output = '';
1.212 foxr 7128:
7129:
1.207 foxr 7130: if($cipher) {
7131: my($enc, $enclength, $encinput) = split(/:/, $input);
7132: for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {
7133: $output .=
7134: $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));
7135: }
7136: return substr($output, 0, $enclength);
7137: } else {
7138: return undef;
7139: }
7140: }
7141:
7142: #
7143: # Register a command processor. This function is invoked to register a sub
7144: # to process a request. Once registered, the ProcessRequest sub can automatically
7145: # dispatch requests to an appropriate sub, and do the top level validity checking
7146: # as well:
7147: # - Is the keyword recognized.
7148: # - Is the proper client type attempting the request.
7149: # - Is the request encrypted if it has to be.
7150: # Parameters:
7151: # $request_name - Name of the request being registered.
7152: # This is the command request that will match
7153: # against the hash keywords to lookup the information
7154: # associated with the dispatch information.
7155: # $procedure - Reference to a sub to call to process the request.
7156: # All subs get called as follows:
7157: # Procedure($cmd, $tail, $replyfd, $key)
7158: # $cmd - the actual keyword that invoked us.
7159: # $tail - the tail of the request that invoked us.
7160: # $replyfd- File descriptor connected to the client
7161: # $must_encode - True if the request must be encoded to be good.
7162: # $client_ok - True if it's ok for a client to request this.
7163: # $manager_ok - True if it's ok for a manager to request this.
7164: # Side effects:
7165: # - On success, the Dispatcher hash has an entry added for the key $RequestName
7166: # - On failure, the program will die as it's a bad internal bug to try to
7167: # register a duplicate command handler.
7168: #
1.211 albertel 7169: sub register_handler {
1.212 foxr 7170: my ($request_name,$procedure,$must_encode, $client_ok,$manager_ok) = @_;
1.207 foxr 7171:
7172: # Don't allow duplication#
7173:
7174: if (defined $Dispatcher{$request_name}) {
7175: die "Attempting to define a duplicate request handler for $request_name\n";
7176: }
7177: # Build the client type mask:
7178:
7179: my $client_type_mask = 0;
7180: if($client_ok) {
7181: $client_type_mask |= $CLIENT_OK;
7182: }
7183: if($manager_ok) {
7184: $client_type_mask |= $MANAGER_OK;
7185: }
7186:
7187: # Enter the hash:
7188:
7189: my @entry = ($procedure, $must_encode, $client_type_mask);
7190:
7191: $Dispatcher{$request_name} = \@entry;
7192:
7193: }
7194:
7195:
7196: #------------------------------------------------------------------
7197:
7198:
7199:
7200:
1.141 foxr 7201: #
1.96 foxr 7202: # Convert an error return code from lcpasswd to a string value.
7203: #
7204: sub lcpasswdstrerror {
7205: my $ErrorCode = shift;
1.97 foxr 7206: if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
1.96 foxr 7207: return "lcpasswd Unrecognized error return value ".$ErrorCode;
7208: } else {
1.98 foxr 7209: return $passwderrors[$ErrorCode];
1.96 foxr 7210: }
7211: }
7212:
1.23 harris41 7213: # grabs exception and records it to log before exiting
7214: sub catchexception {
1.27 albertel 7215: my ($error)=@_;
1.25 www 7216: $SIG{'QUIT'}='DEFAULT';
7217: $SIG{__DIE__}='DEFAULT';
1.165 albertel 7218: &status("Catching exception");
1.190 albertel 7219: &logthis("<font color='red'>CRITICAL: "
1.373 albertel 7220: ."ABNORMAL EXIT. Child $$ for server ".$perlvar{'lonHostID'}." died through "
1.27 albertel 7221: ."a crash with this error msg->[$error]</font>");
1.57 www 7222: &logthis('Famous last words: '.$status.' - '.$lastlog);
1.27 albertel 7223: if ($client) { print $client "error: $error\n"; }
1.59 www 7224: $server->close();
1.27 albertel 7225: die($error);
1.23 harris41 7226: }
1.63 www 7227: sub timeout {
1.165 albertel 7228: &status("Handling Timeout");
1.190 albertel 7229: &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
1.63 www 7230: &catchexception('Timeout');
7231: }
1.22 harris41 7232: # -------------------------------- Set signal handlers to record abnormal exits
7233:
1.226 foxr 7234:
1.22 harris41 7235: $SIG{'QUIT'}=\&catchexception;
7236: $SIG{__DIE__}=\&catchexception;
7237:
1.81 matthew 7238: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
1.95 harris41 7239: &status("Read loncapa.conf and loncapa_apache.conf");
7240: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.141 foxr 7241: %perlvar=%{$perlvarref};
1.80 harris41 7242: undef $perlvarref;
1.19 www 7243:
1.35 harris41 7244: # ----------------------------- Make sure this process is running from user=www
7245: my $wwwid=getpwnam('www');
7246: if ($wwwid!=$<) {
1.134 albertel 7247: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
7248: my $subj="LON: $currenthostid User ID mismatch";
1.550 raeburn 7249: system("echo 'User ID mismatch. lond must be run as user www.' |".
7250: " mail -s '$subj' $emailto > /dev/null");
1.35 harris41 7251: exit 1;
7252: }
7253:
1.19 www 7254: # --------------------------------------------- Check if other instance running
7255:
7256: my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
7257:
7258: if (-e $pidfile) {
7259: my $lfh=IO::File->new("$pidfile");
7260: my $pide=<$lfh>;
7261: chomp($pide);
1.29 harris41 7262: if (kill 0 => $pide) { die "already running"; }
1.19 www 7263: }
1.1 albertel 7264:
7265: # ------------------------------------------------------------- Read hosts file
7266:
7267:
7268:
7269: # establish SERVER socket, bind and listen.
7270: $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
7271: Type => SOCK_STREAM,
7272: Proto => 'tcp',
1.469 foxr 7273: ReuseAddr => 1,
1.1 albertel 7274: Listen => 10 )
1.29 harris41 7275: or die "making socket: $@\n";
1.1 albertel 7276:
7277: # --------------------------------------------------------- Do global variables
7278:
7279: # global variables
7280:
1.134 albertel 7281: my %children = (); # keys are current child process IDs
1.1 albertel 7282:
7283: sub REAPER { # takes care of dead children
7284: $SIG{CHLD} = \&REAPER;
1.165 albertel 7285: &status("Handling child death");
1.178 foxr 7286: my $pid;
7287: do {
7288: $pid = waitpid(-1,&WNOHANG());
7289: if (defined($children{$pid})) {
7290: &logthis("Child $pid died");
7291: delete($children{$pid});
1.183 albertel 7292: } elsif ($pid > 0) {
1.178 foxr 7293: &logthis("Unknown Child $pid died");
7294: }
7295: } while ( $pid > 0 );
7296: foreach my $child (keys(%children)) {
7297: $pid = waitpid($child,&WNOHANG());
7298: if ($pid > 0) {
7299: &logthis("Child $child - $pid looks like we missed it's death");
7300: delete($children{$pid});
7301: }
1.176 albertel 7302: }
1.165 albertel 7303: &status("Finished Handling child death");
1.1 albertel 7304: }
7305:
7306: sub HUNTSMAN { # signal handler for SIGINT
1.165 albertel 7307: &status("Killing children (INT)");
1.1 albertel 7308: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
7309: kill 'INT' => keys %children;
1.59 www 7310: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.1 albertel 7311: my $execdir=$perlvar{'lonDaemons'};
7312: unlink("$execdir/logs/lond.pid");
1.190 albertel 7313: &logthis("<font color='red'>CRITICAL: Shutting down</font>");
1.165 albertel 7314: &status("Done killing children");
1.1 albertel 7315: exit; # clean up with dignity
7316: }
7317:
7318: sub HUPSMAN { # signal handler for SIGHUP
7319: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
1.165 albertel 7320: &status("Killing children for restart (HUP)");
1.1 albertel 7321: kill 'INT' => keys %children;
1.59 www 7322: &logthis("Free socket: ".shutdown($server,2)); # free up socket
1.190 albertel 7323: &logthis("<font color='red'>CRITICAL: Restarting</font>");
1.134 albertel 7324: my $execdir=$perlvar{'lonDaemons'};
1.30 harris41 7325: unlink("$execdir/logs/lond.pid");
1.165 albertel 7326: &status("Restarting self (HUP)");
1.1 albertel 7327: exec("$execdir/lond"); # here we go again
7328: }
7329:
1.144 foxr 7330: #
1.148 foxr 7331: # Reload the Apache daemon's state.
1.150 foxr 7332: # This is done by invoking /home/httpd/perl/apachereload
7333: # a setuid perl script that can be root for us to do this job.
1.148 foxr 7334: #
7335: sub ReloadApache {
1.473 raeburn 7336: # --------------------------- Handle case of another apachereload process (locking)
1.474 raeburn 7337: if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
7338: my $execdir = $perlvar{'lonDaemons'};
7339: my $script = $execdir."/apachereload";
7340: system($script);
7341: unlink('/tmp/lock_apachereload'); # Remove the lock file.
7342: }
1.148 foxr 7343: }
7344:
7345: #
1.144 foxr 7346: # Called in response to a USR2 signal.
7347: # - Reread hosts.tab
7348: # - All children connected to hosts that were removed from hosts.tab
7349: # are killed via SIGINT
7350: # - All children connected to previously existing hosts are sent SIGUSR1
7351: # - Our internal hosts hash is updated to reflect the new contents of
7352: # hosts.tab causing connections from hosts added to hosts.tab to
7353: # now be honored.
7354: #
7355: sub UpdateHosts {
1.165 albertel 7356: &status("Reload hosts.tab");
1.147 foxr 7357: logthis('<font color="blue"> Updating connections </font>');
1.148 foxr 7358: #
7359: # The %children hash has the set of IP's we currently have children
7360: # on. These need to be matched against records in the hosts.tab
7361: # Any ip's no longer in the table get killed off they correspond to
7362: # either dropped or changed hosts. Note that the re-read of the table
7363: # will take care of new and changed hosts as connections come into being.
7364:
1.371 albertel 7365: &Apache::lonnet::reset_hosts_info();
1.532 raeburn 7366: my %active;
1.148 foxr 7367:
1.368 albertel 7368: foreach my $child (keys(%children)) {
1.148 foxr 7369: my $childip = $children{$child};
1.374 albertel 7370: if ($childip ne '127.0.0.1'
7371: && !defined(&Apache::lonnet::get_hosts_from_ip($childip))) {
1.149 foxr 7372: logthis('<font color="blue"> UpdateHosts killing child '
7373: ." $child for ip $childip </font>");
1.148 foxr 7374: kill('INT', $child);
1.149 foxr 7375: } else {
1.532 raeburn 7376: $active{$child} = $childip;
1.149 foxr 7377: logthis('<font color="green"> keeping child for ip '
7378: ." $childip (pid=$child) </font>");
1.148 foxr 7379: }
7380: }
1.532 raeburn 7381:
7382: my %oldconf = %secureconf;
7383: my %connchange;
1.555 raeburn 7384: if (lonssl::Read_Connect_Config(\%secureconf,\%perlvar,\%crlchecked) eq 'ok') {
1.545 raeburn 7385: logthis('<font color="blue"> Reloaded SSL connection rules and cleared CRL checking history </font>');
1.532 raeburn 7386: } else {
1.545 raeburn 7387: logthis('<font color="yellow"> Failed to reload SSL connection rules and clear CRL checking history </font>');
1.532 raeburn 7388: }
7389: if ((ref($oldconf{'connfrom'}) eq 'HASH') && (ref($secureconf{'connfrom'}) eq 'HASH')) {
7390: foreach my $type ('dom','intdom','other') {
7391: if ((($oldconf{'connfrom'}{$type} eq 'no') && ($secureconf{'connfrom'}{$type} eq 'req')) ||
7392: (($oldconf{'connfrom'}{$type} eq 'req') && ($secureconf{'connfrom'}{$type} eq 'no'))) {
7393: $connchange{$type} = 1;
7394: }
7395: }
7396: }
7397: if (keys(%connchange)) {
7398: foreach my $child (keys(%active)) {
7399: my $childip = $active{$child};
7400: if ($childip ne '127.0.0.1') {
7401: my $childhostname = gethostbyaddr(Socket::inet_aton($childip),AF_INET);
7402: if ($childhostname ne '') {
7403: my $childlonhost = &Apache::lonnet::get_server_homeID($childhostname);
7404: my ($samedom,$sameinst) = &set_client_info($childlonhost);
7405: if ($samedom) {
7406: if ($connchange{'dom'}) {
7407: logthis('<font color="blue"> UpdateHosts killing child '
7408: ." $child for ip $childip </font>");
7409: kill('INT', $child);
7410: }
7411: } elsif ($sameinst) {
7412: if ($connchange{'intdom'}) {
7413: logthis('<font color="blue"> UpdateHosts killing child '
7414: ." $child for ip $childip </font>");
7415: kill('INT', $child);
7416: }
7417: } else {
7418: if ($connchange{'other'}) {
7419: logthis('<font color="blue"> UpdateHosts killing child '
7420: ." $child for ip $childip </font>");
7421: kill('INT', $child);
7422: }
7423: }
7424: }
7425: }
7426: }
7427: }
1.148 foxr 7428: ReloadApache;
1.165 albertel 7429: &status("Finished reloading hosts.tab");
1.144 foxr 7430: }
7431:
1.57 www 7432: sub checkchildren {
1.165 albertel 7433: &status("Checking on the children (sending signals)");
1.57 www 7434: &initnewstatus();
7435: &logstatus();
7436: &logthis('Going to check on the children');
1.134 albertel 7437: my $docdir=$perlvar{'lonDocRoot'};
1.61 harris41 7438: foreach (sort keys %children) {
1.221 albertel 7439: #sleep 1;
1.57 www 7440: unless (kill 'USR1' => $_) {
7441: &logthis ('Child '.$_.' is dead');
7442: &logstatus($$.' is dead');
1.221 albertel 7443: delete($children{$_});
1.57 www 7444: }
1.61 harris41 7445: }
1.63 www 7446: sleep 5;
1.212 foxr 7447: $SIG{ALRM} = sub { Debug("timeout");
7448: die "timeout"; };
1.113 albertel 7449: $SIG{__DIE__} = 'DEFAULT';
1.165 albertel 7450: &status("Checking on the children (waiting for reports)");
1.63 www 7451: foreach (sort keys %children) {
7452: unless (-e "$docdir/lon-status/londchld/$_.txt") {
1.113 albertel 7453: eval {
7454: alarm(300);
1.63 www 7455: &logthis('Child '.$_.' did not respond');
1.67 albertel 7456: kill 9 => $_;
1.131 albertel 7457: #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
7458: #$subj="LON: $currenthostid killed lond process $_";
7459: #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
7460: #$execdir=$perlvar{'lonDaemons'};
7461: #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
1.221 albertel 7462: delete($children{$_});
1.113 albertel 7463: alarm(0);
7464: }
1.63 www 7465: }
7466: }
1.113 albertel 7467: $SIG{ALRM} = 'DEFAULT';
1.155 albertel 7468: $SIG{__DIE__} = \&catchexception;
1.165 albertel 7469: &status("Finished checking children");
1.221 albertel 7470: &logthis('Finished Checking children');
1.57 www 7471: }
7472:
1.1 albertel 7473: # --------------------------------------------------------------------- Logging
7474:
7475: sub logthis {
7476: my $message=shift;
7477: my $execdir=$perlvar{'lonDaemons'};
7478: my $fh=IO::File->new(">>$execdir/logs/lond.log");
7479: my $now=time;
7480: my $local=localtime($now);
1.58 www 7481: $lastlog=$local.': '.$message;
1.1 albertel 7482: print $fh "$local ($$): $message\n";
7483: }
7484:
1.77 foxr 7485: # ------------------------- Conditional log if $DEBUG true.
7486: sub Debug {
7487: my $message = shift;
7488: if($DEBUG) {
7489: &logthis($message);
7490: }
7491: }
1.161 foxr 7492:
7493: #
7494: # Sub to do replies to client.. this gives a hook for some
7495: # debug tracing too:
7496: # Parameters:
7497: # fd - File open on client.
7498: # reply - Text to send to client.
7499: # request - Original request from client.
7500: #
1.490 droeschl 7501: #NOTE $reply must be terminated by exactly *one* \n. If $reply is a reference
7502: #this is done automatically ($$reply must not contain any \n in this case).
7503: #If $reply is a string the caller has to ensure this.
1.161 foxr 7504: sub Reply {
1.192 foxr 7505: my ($fd, $reply, $request) = @_;
1.387 albertel 7506: if (ref($reply)) {
7507: print $fd $$reply;
7508: print $fd "\n";
7509: if ($DEBUG) { Debug("Request was $request Reply was $$reply"); }
7510: } else {
7511: print $fd $reply;
7512: if ($DEBUG) { Debug("Request was $request Reply was $reply"); }
7513: }
1.212 foxr 7514: $Transactions++;
7515: }
7516:
7517:
7518: #
7519: # Sub to report a failure.
7520: # This function:
7521: # - Increments the failure statistic counters.
7522: # - Invokes Reply to send the error message to the client.
7523: # Parameters:
7524: # fd - File descriptor open on the client
7525: # reply - Reply text to emit.
7526: # request - The original request message (used by Reply
7527: # to debug if that's enabled.
7528: # Implicit outputs:
7529: # $Failures- The number of failures is incremented.
7530: # Reply (invoked here) sends a message to the
7531: # client:
7532: #
7533: sub Failure {
7534: my $fd = shift;
7535: my $reply = shift;
7536: my $request = shift;
7537:
7538: $Failures++;
7539: Reply($fd, $reply, $request); # That's simple eh?
1.161 foxr 7540: }
1.57 www 7541: # ------------------------------------------------------------------ Log status
7542:
7543: sub logstatus {
1.178 foxr 7544: &status("Doing logging");
7545: my $docdir=$perlvar{'lonDocRoot'};
7546: {
7547: my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
1.200 matthew 7548: print $fh $status."\n".$lastlog."\n".time."\n$keymode";
1.178 foxr 7549: $fh->close();
7550: }
1.221 albertel 7551: &status("Finished $$.txt");
7552: {
7553: open(LOG,">>$docdir/lon-status/londstatus.txt");
7554: flock(LOG,LOCK_EX);
7555: print LOG $$."\t".$clientname."\t".$currenthostid."\t"
7556: .$status."\t".$lastlog."\t $keymode\n";
1.275 albertel 7557: flock(LOG,LOCK_UN);
1.221 albertel 7558: close(LOG);
7559: }
1.178 foxr 7560: &status("Finished logging");
1.57 www 7561: }
7562:
7563: sub initnewstatus {
7564: my $docdir=$perlvar{'lonDocRoot'};
7565: my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
1.460 foxr 7566: my $now=time();
1.57 www 7567: my $local=localtime($now);
7568: print $fh "LOND status $local - parent $$\n\n";
1.64 www 7569: opendir(DIR,"$docdir/lon-status/londchld");
1.134 albertel 7570: while (my $filename=readdir(DIR)) {
1.64 www 7571: unlink("$docdir/lon-status/londchld/$filename");
7572: }
7573: closedir(DIR);
1.57 www 7574: }
7575:
7576: # -------------------------------------------------------------- Status setting
7577:
7578: sub status {
7579: my $what=shift;
7580: my $now=time;
7581: my $local=localtime($now);
1.178 foxr 7582: $status=$local.': '.$what;
7583: $0='lond: '.$what.' '.$local;
1.57 www 7584: }
1.11 www 7585:
1.13 www 7586: # -------------------------------------------------------------- Talk to lonsql
7587:
1.234 foxr 7588: sub sql_reply {
1.12 harris41 7589: my ($cmd)=@_;
1.234 foxr 7590: my $answer=&sub_sql_reply($cmd);
7591: if ($answer eq 'con_lost') { $answer=&sub_sql_reply($cmd); }
1.12 harris41 7592: return $answer;
7593: }
7594:
1.234 foxr 7595: sub sub_sql_reply {
1.12 harris41 7596: my ($cmd)=@_;
7597: my $unixsock="mysqlsock";
7598: my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
7599: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
7600: Type => SOCK_STREAM,
7601: Timeout => 10)
7602: or return "con_lost";
1.319 www 7603: print $sclient "$cmd:$currentdomainid\n";
1.12 harris41 7604: my $answer=<$sclient>;
7605: chomp($answer);
7606: if (!$answer) { $answer="con_lost"; }
7607: return $answer;
7608: }
7609:
1.1 albertel 7610: # --------------------------------------- Is this the home server of an author?
1.11 www 7611:
1.1 albertel 7612: sub ishome {
7613: my $author=shift;
7614: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
7615: my ($udom,$uname)=split(/\//,$author);
7616: my $proname=propath($udom,$uname);
7617: if (-e $proname) {
7618: return 'owner';
7619: } else {
7620: return 'not_owner';
7621: }
7622: }
7623:
7624: # ======================================================= Continue main program
7625: # ---------------------------------------------------- Fork once and dissociate
7626:
1.134 albertel 7627: my $fpid=fork;
1.1 albertel 7628: exit if $fpid;
1.29 harris41 7629: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 7630:
1.29 harris41 7631: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 7632:
7633: # ------------------------------------------------------- Write our PID on disk
7634:
1.134 albertel 7635: my $execdir=$perlvar{'lonDaemons'};
1.1 albertel 7636: open (PIDSAVE,">$execdir/logs/lond.pid");
7637: print PIDSAVE "$$\n";
7638: close(PIDSAVE);
1.190 albertel 7639: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
1.57 www 7640: &status('Starting');
1.1 albertel 7641:
1.106 foxr 7642:
1.1 albertel 7643:
7644: # ----------------------------------------------------- Install signal handlers
7645:
1.57 www 7646:
1.1 albertel 7647: $SIG{CHLD} = \&REAPER;
7648: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
7649: $SIG{HUP} = \&HUPSMAN;
1.57 www 7650: $SIG{USR1} = \&checkchildren;
1.144 foxr 7651: $SIG{USR2} = \&UpdateHosts;
1.106 foxr 7652:
1.148 foxr 7653: # Read the host hashes:
1.368 albertel 7654: &Apache::lonnet::load_hosts_tab();
1.447 raeburn 7655: my %iphost = &Apache::lonnet::get_iphost(1);
1.106 foxr 7656:
1.480 raeburn 7657: $dist=`$perlvar{'lonDaemons'}/distprobe`;
1.286 albertel 7658:
1.471 raeburn 7659: my $arch = `uname -i`;
1.475 raeburn 7660: chomp($arch);
1.471 raeburn 7661: if ($arch eq 'unknown') {
7662: $arch = `uname -m`;
1.475 raeburn 7663: chomp($arch);
1.471 raeburn 7664: }
7665:
1.555 raeburn 7666: unless (lonssl::Read_Connect_Config(\%secureconf,\%perlvar,\%crlchecked) eq 'ok') {
1.532 raeburn 7667: &logthis('<font color="blue">No connectionrules table. Will fallback to loncapa.conf</font>');
7668: }
7669:
1.106 foxr 7670: # --------------------------------------------------------------
7671: # Accept connections. When a connection comes in, it is validated
7672: # and if good, a child process is created to process transactions
7673: # along the connection.
7674:
1.1 albertel 7675: while (1) {
1.165 albertel 7676: &status('Starting accept');
1.106 foxr 7677: $client = $server->accept() or next;
1.165 albertel 7678: &status('Accepted '.$client.' off to spawn');
1.386 albertel 7679: make_new_child($client);
1.165 albertel 7680: &status('Finished spawning');
1.1 albertel 7681: }
7682:
1.212 foxr 7683: sub make_new_child {
7684: my $pid;
7685: # my $cipher; # Now global
7686: my $sigset;
1.178 foxr 7687:
1.212 foxr 7688: $client = shift;
7689: &status('Starting new child '.$client);
7690: &logthis('<font color="green"> Attempting to start child ('.$client.
7691: ")</font>");
7692: # block signal for fork
7693: $sigset = POSIX::SigSet->new(SIGINT);
7694: sigprocmask(SIG_BLOCK, $sigset)
7695: or die "Can't block SIGINT for fork: $!\n";
1.178 foxr 7696:
1.212 foxr 7697: die "fork: $!" unless defined ($pid = fork);
1.178 foxr 7698:
1.212 foxr 7699: $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
7700: # connection liveness.
1.178 foxr 7701:
1.212 foxr 7702: #
7703: # Figure out who we're talking to so we can record the peer in
7704: # the pid hash.
7705: #
7706: my $caller = getpeername($client);
7707: my ($port,$iaddr);
7708: if (defined($caller) && length($caller) > 0) {
7709: ($port,$iaddr)=unpack_sockaddr_in($caller);
7710: } else {
7711: &logthis("Unable to determine who caller was, getpeername returned nothing");
7712: }
7713: if (defined($iaddr)) {
7714: $clientip = inet_ntoa($iaddr);
7715: Debug("Connected with $clientip");
7716: } else {
7717: &logthis("Unable to determine clientip");
7718: $clientip='Unavailable';
7719: }
7720:
7721: if ($pid) {
7722: # Parent records the child's birth and returns.
7723: sigprocmask(SIG_UNBLOCK, $sigset)
7724: or die "Can't unblock SIGINT for fork: $!\n";
7725: $children{$pid} = $clientip;
7726: &status('Started child '.$pid);
1.462 foxr 7727: close($client);
1.212 foxr 7728: return;
7729: } else {
7730: # Child can *not* return from this subroutine.
7731: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
7732: $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
7733: #don't get intercepted
7734: $SIG{USR1}= \&logstatus;
7735: $SIG{ALRM}= \&timeout;
1.468 foxr 7736: #
7737: # Block sigpipe as it gets thrownon socket disconnect and we want to
7738: # deal with that as a read faiure instead.
7739: #
7740: my $blockset = POSIX::SigSet->new(SIGPIPE);
7741: sigprocmask(SIG_BLOCK, $blockset);
7742:
1.212 foxr 7743: $lastlog='Forked ';
7744: $status='Forked';
1.178 foxr 7745:
1.212 foxr 7746: # unblock signals
7747: sigprocmask(SIG_UNBLOCK, $sigset)
7748: or die "Can't unblock SIGINT for fork: $!\n";
1.178 foxr 7749:
1.212 foxr 7750: # my $tmpsnum=0; # Now global
7751: #---------------------------------------------------- kerberos 5 initialization
7752: &Authen::Krb5::init_context();
1.511 raeburn 7753:
7754: my $no_ets;
1.559 raeburn 7755: if ($dist =~ /^(?:centos|rhes|scientific|oracle)(\d+)$/) {
1.511 raeburn 7756: if ($1 >= 7) {
7757: $no_ets = 1;
7758: }
7759: } elsif ($dist =~ /^suse(\d+\.\d+)$/) {
7760: if (($1 eq '9.3') || ($1 >= 12.2)) {
7761: $no_ets = 1;
7762: }
1.514 raeburn 7763: } elsif ($dist =~ /^sles(\d+)$/) {
7764: if ($1 > 11) {
7765: $no_ets = 1;
7766: }
1.511 raeburn 7767: } elsif ($dist =~ /^fedora(\d+)$/) {
7768: if ($1 < 7) {
7769: $no_ets = 1;
7770: }
7771: }
7772: unless ($no_ets) {
1.286 albertel 7773: &Authen::Krb5::init_ets();
7774: }
1.209 albertel 7775:
1.212 foxr 7776: &status('Accepted connection');
7777: # =============================================================================
7778: # do something with the connection
7779: # -----------------------------------------------------------------------------
7780: # see if we know client and 'check' for spoof IP by ineffective challenge
1.178 foxr 7781:
1.278 albertel 7782: my $outsideip=$clientip;
7783: if ($clientip eq '127.0.0.1') {
1.368 albertel 7784: $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
1.278 albertel 7785: }
1.412 foxr 7786: &ReadManagerTable();
1.368 albertel 7787: my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
1.278 albertel 7788: my $ismanager=($managers{$outsideip} ne undef);
1.432 raeburn 7789: $clientname = "[unknown]";
1.212 foxr 7790: if($clientrec) { # Establish client type.
7791: $ConnectionType = "client";
1.368 albertel 7792: $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
1.212 foxr 7793: if($ismanager) {
7794: $ConnectionType = "both";
7795: }
7796: } else {
7797: $ConnectionType = "manager";
1.278 albertel 7798: $clientname = $managers{$outsideip};
1.212 foxr 7799: }
1.556 raeburn 7800: my $clientok;
1.178 foxr 7801:
1.212 foxr 7802: if ($clientrec || $ismanager) {
7803: &status("Waiting for init from $clientip $clientname");
7804: &logthis('<font color="yellow">INFO: Connection, '.
7805: $clientip.
7806: " ($clientname) connection type = $ConnectionType </font>" );
7807: &status("Connecting $clientip ($clientname))");
7808: my $remotereq=<$client>;
7809: chomp($remotereq);
7810: Debug("Got init: $remotereq");
1.337 albertel 7811:
1.212 foxr 7812: if ($remotereq =~ /^init/) {
7813: &sethost("sethost:$perlvar{'lonHostID'}");
7814: #
7815: # If the remote is attempting a local init... give that a try:
7816: #
1.432 raeburn 7817: (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
1.492 droeschl 7818: # For LON-CAPA 2.9, the client session will have sent its LON-CAPA
7819: # version when initiating the connection. For LON-CAPA 2.8 and older,
7820: # the version is retrieved from the global %loncaparevs in lonnet.pm.
1.494 droeschl 7821: # $clientversion contains path to keyfile if $inittype eq 'local'
7822: # it's overridden below in this case
1.492 droeschl 7823: $clientversion ||= $Apache::lonnet::loncaparevs{$clientname};
1.209 albertel 7824:
1.212 foxr 7825: # If the connection type is ssl, but I didn't get my
7826: # certificate files yet, then I'll drop back to
7827: # insecure (if allowed).
1.532 raeburn 7828:
7829: if ($inittype eq "ssl") {
7830: my $context;
7831: if ($clientsamedom) {
7832: $context = 'dom';
7833: if ($secureconf{'connfrom'}{'dom'} eq 'no') {
7834: $inittype = "";
7835: }
7836: } elsif ($clientsameinst) {
7837: $context = 'intdom';
7838: if ($secureconf{'connfrom'}{'intdom'} eq 'no') {
7839: $inittype = "";
7840: }
7841: } else {
7842: $context = 'other';
7843: if ($secureconf{'connfrom'}{'other'} eq 'no') {
7844: $inittype = "";
7845: }
7846: }
7847: if ($inittype eq '') {
7848: &logthis("<font color=\"blue\"> Domain config set "
7849: ."to no ssl for $clientname (context: $context)"
7850: ." -- trying insecure auth</font>");
7851: }
7852: }
7853:
1.212 foxr 7854: if($inittype eq "ssl") {
7855: my ($ca, $cert) = lonssl::CertificateFile;
7856: my $kfile = lonssl::KeyFile;
7857: if((!$ca) ||
7858: (!$cert) ||
7859: (!$kfile)) {
7860: $inittype = ""; # This forces insecure attempt.
7861: &logthis("<font color=\"blue\"> Certificates not "
7862: ."installed -- trying insecure auth</font>");
1.224 foxr 7863: } else { # SSL certificates are in place so
1.212 foxr 7864: } # Leave the inittype alone.
7865: }
7866:
7867: if($inittype eq "local") {
1.432 raeburn 7868: $clientversion = $perlvar{'lonVersion'};
1.212 foxr 7869: my $key = LocalConnection($client, $remotereq);
7870: if($key) {
7871: Debug("Got local key $key");
7872: $clientok = 1;
7873: my $cipherkey = pack("H32", $key);
7874: $cipher = new IDEA($cipherkey);
7875: print $client "ok:local\n";
1.442 www 7876: &logthis('<font color="green">'
1.212 foxr 7877: . "Successful local authentication </font>");
7878: $keymode = "local"
1.178 foxr 7879: } else {
1.212 foxr 7880: Debug("Failed to get local key");
7881: $clientok = 0;
7882: shutdown($client, 3);
7883: close $client;
1.178 foxr 7884: }
1.212 foxr 7885: } elsif ($inittype eq "ssl") {
1.532 raeburn 7886: my $key = SSLConnection($client,$clientname);
1.212 foxr 7887: if ($key) {
7888: $clientok = 1;
7889: my $cipherkey = pack("H32", $key);
7890: $cipher = new IDEA($cipherkey);
7891: &logthis('<font color="green">'
7892: ."Successfull ssl authentication with $clientname </font>");
7893: $keymode = "ssl";
7894:
1.178 foxr 7895: } else {
1.212 foxr 7896: $clientok = 0;
7897: close $client;
1.178 foxr 7898: }
1.212 foxr 7899:
7900: } else {
7901: my $ok = InsecureConnection($client);
7902: if($ok) {
7903: $clientok = 1;
7904: &logthis('<font color="green">'
7905: ."Successful insecure authentication with $clientname </font>");
7906: print $client "ok\n";
7907: $keymode = "insecure";
1.178 foxr 7908: } else {
1.212 foxr 7909: &logthis('<font color="yellow">'
7910: ."Attempted insecure connection disallowed </font>");
7911: close $client;
7912: $clientok = 0;
1.178 foxr 7913: }
7914: }
1.212 foxr 7915: } else {
7916: &logthis(
7917: "<font color='blue'>WARNING: "
7918: ."$clientip failed to initialize: >$remotereq< </font>");
7919: &status('No init '.$clientip);
7920: }
7921: } else {
7922: &logthis(
7923: "<font color='blue'>WARNING: Unknown client $clientip</font>");
7924: &status('Hung up on '.$clientip);
7925: }
7926:
7927: if ($clientok) {
7928: # ---------------- New known client connecting, could mean machine online again
1.368 albertel 7929: if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip
1.367 albertel 7930: && $clientip ne '127.0.0.1') {
1.375 albertel 7931: &Apache::lonnet::reconlonc($clientname);
1.212 foxr 7932: }
7933: &logthis("<font color='green'>Established connection: $clientname</font>");
7934: &status('Will listen to '.$clientname);
7935: # ------------------------------------------------------------ Process requests
7936: my $keep_going = 1;
7937: my $user_input;
1.556 raeburn 7938:
1.212 foxr 7939: while(($user_input = get_request) && $keep_going) {
7940: alarm(120);
7941: Debug("Main: Got $user_input\n");
7942: $keep_going = &process_request($user_input);
1.178 foxr 7943: alarm(0);
1.212 foxr 7944: &status('Listening to '.$clientname." ($keymode)");
1.161 foxr 7945: }
1.212 foxr 7946:
1.59 www 7947: # --------------------------------------------- client unknown or fishy, refuse
1.212 foxr 7948: } else {
1.161 foxr 7949: print $client "refused\n";
7950: $client->close();
1.190 albertel 7951: &logthis("<font color='blue'>WARNING: "
1.161 foxr 7952: ."Rejected client $clientip, closing connection</font>");
7953: }
1.525 raeburn 7954: }
1.161 foxr 7955:
1.1 albertel 7956: # =============================================================================
1.161 foxr 7957:
1.190 albertel 7958: &logthis("<font color='red'>CRITICAL: "
1.161 foxr 7959: ."Disconnect from $clientip ($clientname)</font>");
7960:
7961:
7962: # this exit is VERY important, otherwise the child will become
7963: # a producer of more and more children, forking yourself into
7964: # process death.
7965: exit;
1.106 foxr 7966:
1.78 foxr 7967: }
1.532 raeburn 7968:
7969: #
7970: # Used to determine if a particular client is from the same domain
1.556 raeburn 7971: # as the current server, or from the same internet domain, and
7972: # also if the client can host sessions for the domain's users.
7973: # A hash is populated with keys set to commands sent by the client
7974: # which may not be executed for this domain.
1.532 raeburn 7975: #
7976: # Optional input -- the client to check for domain and internet domain.
7977: # If not specified, defaults to the package variable: $clientname
7978: #
7979: # If called in array context will not set package variables, but will
7980: # instead return an array of two values - (a) true if client is in the
1.556 raeburn 7981: # same domain as the server, and (b) true if client is in the same
7982: # internet domain.
1.532 raeburn 7983: #
7984: # If called in scalar context, sets package variables for current client:
7985: #
1.556 raeburn 7986: # $clienthomedom - LonCAPA domain of homeID for client.
7987: # $clientsamedom - LonCAPA domain same for this host and client.
7988: # $clientintdom - LonCAPA "internet domain" for client.
7989: # $clientsameinst - LonCAPA "internet domain" same for this host & client.
7990: # $clientremoteok - If current domain permits hosting on this client: 1
7991: # %clientprohibited - Commands prohibited for domain's users for this client.
7992: #
7993: # if the host and client have the same "internet domain", then the value
7994: # of $clientremoteok is not used, and no commands are prohibited.
1.532 raeburn 7995: #
7996: # returns 1 to indicate package variables have been set for current client.
7997: #
7998:
7999: sub set_client_info {
8000: my ($lonhost) = @_;
8001: $lonhost ||= $clientname;
8002: my $clienthost = &Apache::lonnet::hostname($lonhost);
8003: my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
8004: my $homedom = &Apache::lonnet::host_domain($clientserverhomeID);
8005: my $samedom = 0;
1.557 raeburn 8006: if ($perlvar{'lonDefDomain'} eq $homedom) {
1.532 raeburn 8007: $samedom = 1;
8008: }
8009: my $intdom = &Apache::lonnet::internet_dom($clientserverhomeID);
8010: my $sameinst = 0;
8011: if ($intdom ne '') {
8012: my $internet_names = &Apache::lonnet::get_internet_names($currenthostid);
8013: if (ref($internet_names) eq 'ARRAY') {
8014: if (grep(/^\Q$intdom\E$/,@{$internet_names})) {
8015: $sameinst = 1;
8016: }
8017: }
8018: }
8019: if (wantarray) {
8020: return ($samedom,$sameinst);
8021: } else {
8022: $clienthomedom = $homedom;
8023: $clientsamedom = $samedom;
8024: $clientintdom = $intdom;
8025: $clientsameinst = $sameinst;
1.556 raeburn 8026: if ($clientsameinst) {
8027: undef($clientremoteok);
8028: undef(%clientprohibited);
8029: } else {
8030: $clientremoteok = &get_remote_hostable($currentdomainid);
8031: %clientprohibited = &get_prohibited($currentdomainid);
8032: }
1.532 raeburn 8033: return 1;
8034: }
8035: }
8036:
1.261 foxr 8037: #
8038: # Determine if a user is an author for the indicated domain.
8039: #
8040: # Parameters:
8041: # domain - domain to check in .
8042: # user - Name of user to check.
8043: #
8044: # Return:
8045: # 1 - User is an author for domain.
8046: # 0 - User is not an author for domain.
8047: sub is_author {
8048: my ($domain, $user) = @_;
8049:
8050: &Debug("is_author: $user @ $domain");
8051:
8052: my $hashref = &tie_user_hash($domain, $user, "roles",
8053: &GDBM_READER());
8054:
8055: # Author role should show up as a key /domain/_au
1.78 foxr 8056:
1.321 albertel 8057: my $value;
1.487 foxr 8058: if ($hashref) {
1.78 foxr 8059:
1.487 foxr 8060: my $key = "/$domain/_au";
8061: if (defined($hashref)) {
8062: $value = $hashref->{$key};
8063: if(!untie_user_hash($hashref)) {
8064: return 'error: ' . ($!+0)." untie (GDBM) Failed";
8065: }
8066: }
8067:
8068: if(defined($value)) {
8069: &Debug("$user @ $domain is an author");
8070: }
8071: } else {
8072: return 'error: '.($!+0)." tie (GDBM) Failed";
1.261 foxr 8073: }
8074:
8075: return defined($value);
8076: }
1.78 foxr 8077: #
8078: # Checks to see if the input roleput request was to set
1.482 www 8079: # an author role. If so, creates construction space
1.78 foxr 8080: # Parameters:
8081: # request - The request sent to the rolesput subchunk.
8082: # We're looking for /domain/_au
8083: # domain - The domain in which the user is having roles doctored.
8084: # user - Name of the user for which the role is being put.
8085: # authtype - The authentication type associated with the user.
8086: #
1.289 albertel 8087: sub manage_permissions {
1.192 foxr 8088: my ($request, $domain, $user, $authtype) = @_;
1.78 foxr 8089: # See if the request is of the form /$domain/_au
1.289 albertel 8090: if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
1.484 raeburn 8091: my $path=$perlvar{'lonDocRoot'}."/priv/$domain";
1.482 www 8092: unless (-e $path) {
8093: mkdir($path);
8094: }
8095: unless (-e $path.'/'.$user) {
8096: mkdir($path.'/'.$user);
8097: }
1.78 foxr 8098: }
8099: }
1.222 foxr 8100:
8101:
8102: #
8103: # Return the full path of a user password file, whether it exists or not.
8104: # Parameters:
8105: # domain - Domain in which the password file lives.
8106: # user - name of the user.
8107: # Returns:
8108: # Full passwd path:
8109: #
8110: sub password_path {
8111: my ($domain, $user) = @_;
1.264 albertel 8112: return &propath($domain, $user).'/passwd';
1.222 foxr 8113: }
8114:
8115: # Password Filename
8116: # Returns the path to a passwd file given domain and user... only if
8117: # it exists.
8118: # Parameters:
8119: # domain - Domain in which to search.
8120: # user - username.
8121: # Returns:
8122: # - If the password file exists returns its path.
8123: # - If the password file does not exist, returns undefined.
8124: #
8125: sub password_filename {
8126: my ($domain, $user) = @_;
8127:
8128: Debug ("PasswordFilename called: dom = $domain user = $user");
8129:
8130: my $path = &password_path($domain, $user);
8131: Debug("PasswordFilename got path: $path");
8132: if(-e $path) {
8133: return $path;
8134: } else {
8135: return undef;
8136: }
8137: }
8138:
8139: #
8140: # Rewrite the contents of the user's passwd file.
8141: # Parameters:
8142: # domain - domain of the user.
8143: # name - User's name.
8144: # contents - New contents of the file.
1.533 raeburn 8145: # saveold - (optional). If true save old file in a passwd.bak file.
1.222 foxr 8146: # Returns:
8147: # 0 - Failed.
8148: # 1 - Success.
8149: #
8150: sub rewrite_password_file {
1.533 raeburn 8151: my ($domain, $user, $contents, $saveold) = @_;
1.222 foxr 8152:
8153: my $file = &password_filename($domain, $user);
8154: if (defined $file) {
1.533 raeburn 8155: if ($saveold) {
8156: my $bakfile = $file.'.bak';
8157: if (CopyFile($file,$bakfile)) {
8158: chmod(0400,$bakfile);
8159: &logthis("Old password saved in passwd.bak for internally authenticated user: $user:$domain");
8160: } else {
8161: &logthis("Failed to save old password in passwd.bak for internally authenticated user: $user:$domain");
8162: }
8163: }
1.222 foxr 8164: my $pf = IO::File->new(">$file");
8165: if($pf) {
8166: print $pf "$contents\n";
8167: return 1;
8168: } else {
8169: return 0;
8170: }
8171: } else {
8172: return 0;
8173: }
8174:
8175: }
8176:
1.78 foxr 8177: #
1.222 foxr 8178: # get_auth_type - Determines the authorization type of a user in a domain.
1.78 foxr 8179:
8180: # Returns the authorization type or nouser if there is no such user.
8181: #
1.436 raeburn 8182: sub get_auth_type {
1.192 foxr 8183: my ($domain, $user) = @_;
1.78 foxr 8184:
1.222 foxr 8185: Debug("get_auth_type( $domain, $user ) \n");
1.78 foxr 8186: my $proname = &propath($domain, $user);
8187: my $passwdfile = "$proname/passwd";
8188: if( -e $passwdfile ) {
8189: my $pf = IO::File->new($passwdfile);
8190: my $realpassword = <$pf>;
8191: chomp($realpassword);
1.79 foxr 8192: Debug("Password info = $realpassword\n");
1.78 foxr 8193: my ($authtype, $contentpwd) = split(/:/, $realpassword);
1.79 foxr 8194: Debug("Authtype = $authtype, content = $contentpwd\n");
1.259 raeburn 8195: return "$authtype:$contentpwd";
1.224 foxr 8196: } else {
1.79 foxr 8197: Debug("Returning nouser");
1.78 foxr 8198: return "nouser";
8199: }
1.1 albertel 8200: }
8201:
1.220 foxr 8202: #
8203: # Validate a user given their domain, name and password. This utility
8204: # function is used by both AuthenticateHandler and ChangePasswordHandler
8205: # to validate the login credentials of a user.
8206: # Parameters:
8207: # $domain - The domain being logged into (this is required due to
8208: # the capability for multihomed systems.
8209: # $user - The name of the user being validated.
8210: # $password - The user's propoposed password.
8211: #
8212: # Returns:
8213: # 1 - The domain,user,pasword triplet corresponds to a valid
8214: # user.
8215: # 0 - The domain,user,password triplet is not a valid user.
8216: #
8217: sub validate_user {
1.396 raeburn 8218: my ($domain, $user, $password, $checkdefauth) = @_;
1.220 foxr 8219:
8220: # Why negative ~pi you may well ask? Well this function is about
8221: # authentication, and therefore very important to get right.
8222: # I've initialized the flag that determines whether or not I've
8223: # validated correctly to a value it's not supposed to get.
8224: # At the end of this function. I'll ensure that it's not still that
8225: # value so we don't just wind up returning some accidental value
8226: # as a result of executing an unforseen code path that
1.249 foxr 8227: # did not set $validated. At the end of valid execution paths,
8228: # validated shoule be 1 for success or 0 for failuer.
1.220 foxr 8229:
8230: my $validated = -3.14159;
8231:
8232: # How we authenticate is determined by the type of authentication
8233: # the user has been assigned. If the authentication type is
8234: # "nouser", the user does not exist so we will return 0.
8235:
1.222 foxr 8236: my $contents = &get_auth_type($domain, $user);
1.220 foxr 8237: my ($howpwd, $contentpwd) = split(/:/, $contents);
8238:
8239: my $null = pack("C",0); # Used by kerberos auth types.
8240:
1.395 raeburn 8241: if ($howpwd eq 'nouser') {
1.396 raeburn 8242: if ($checkdefauth) {
8243: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
8244: if ($domdefaults{'auth_def'} eq 'localauth') {
8245: $howpwd = $domdefaults{'auth_def'};
8246: $contentpwd = $domdefaults{'auth_arg_def'};
8247: } elsif ((($domdefaults{'auth_def'} eq 'krb4') ||
8248: ($domdefaults{'auth_def'} eq 'krb5')) &&
8249: ($domdefaults{'auth_arg_def'} ne '')) {
8250: $howpwd = $domdefaults{'auth_def'};
8251: $contentpwd = $domdefaults{'auth_arg_def'};
8252: }
1.395 raeburn 8253: }
1.533 raeburn 8254: }
1.220 foxr 8255: if ($howpwd ne 'nouser') {
8256: if($howpwd eq "internal") { # Encrypted is in local password file.
1.518 raeburn 8257: if (length($contentpwd) == 13) {
8258: $validated = (crypt($password,$contentpwd) eq $contentpwd);
8259: if ($validated) {
1.533 raeburn 8260: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
8261: if ($domdefaults{'intauth_switch'}) {
8262: my $ncpass = &hash_passwd($domain,$password);
8263: my $saveold;
8264: if ($domdefaults{'intauth_switch'} == 2) {
8265: $saveold = 1;
8266: }
8267: if (&rewrite_password_file($domain,$user,"$howpwd:$ncpass",$saveold)) {
8268: &update_passwd_history($user,$domain,$howpwd,'conversion');
8269: &logthis("Validated password hashed with bcrypt for $user:$domain");
8270: }
1.518 raeburn 8271: }
8272: }
8273: } else {
1.533 raeburn 8274: $validated = &check_internal_passwd($password,$contentpwd,$domain,$user);
1.518 raeburn 8275: }
1.220 foxr 8276: }
8277: elsif ($howpwd eq "unix") { # User is a normal unix user.
8278: $contentpwd = (getpwnam($user))[1];
8279: if($contentpwd) {
8280: if($contentpwd eq 'x') { # Shadow password file...
8281: my $pwauth_path = "/usr/local/sbin/pwauth";
8282: open PWAUTH, "|$pwauth_path" or
8283: die "Cannot invoke authentication";
8284: print PWAUTH "$user\n$password\n";
8285: close PWAUTH;
8286: $validated = ! $?;
8287:
8288: } else { # Passwords in /etc/passwd.
8289: $validated = (crypt($password,
8290: $contentpwd) eq $contentpwd);
8291: }
8292: } else {
8293: $validated = 0;
8294: }
1.439 raeburn 8295: } elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
8296: my $checkwithkrb5 = 0;
8297: if ($dist =~/^fedora(\d+)$/) {
8298: if ($1 > 11) {
8299: $checkwithkrb5 = 1;
8300: }
8301: } elsif ($dist =~ /^suse([\d.]+)$/) {
8302: if ($1 > 11.1) {
8303: $checkwithkrb5 = 1;
8304: }
8305: }
8306: if ($checkwithkrb5) {
8307: $validated = &krb5_authen($password,$null,$user,$contentpwd);
8308: } else {
8309: $validated = &krb4_authen($password,$null,$user,$contentpwd);
8310: }
1.224 foxr 8311: } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
1.439 raeburn 8312: $validated = &krb5_authen($password,$null,$user,$contentpwd);
1.224 foxr 8313: } elsif ($howpwd eq "localauth") {
1.220 foxr 8314: # Authenticate via installation specific authentcation method:
8315: $validated = &localauth::localauth($user,
8316: $password,
1.353 albertel 8317: $contentpwd,
8318: $domain);
1.358 albertel 8319: if ($validated < 0) {
1.357 albertel 8320: &logthis("localauth for $contentpwd $user:$domain returned a $validated");
8321: $validated = 0;
8322: }
1.224 foxr 8323: } else { # Unrecognized auth is also bad.
1.220 foxr 8324: $validated = 0;
8325: }
8326: } else {
8327: $validated = 0;
8328: }
8329: #
8330: # $validated has the correct stat of the authentication:
8331: #
8332:
8333: unless ($validated != -3.14159) {
1.249 foxr 8334: # I >really really< want to know if this happens.
8335: # since it indicates that user authentication is badly
8336: # broken in some code path.
8337: #
8338: die "ValidateUser - failed to set the value of validated $domain, $user $password";
1.220 foxr 8339: }
8340: return $validated;
8341: }
8342:
1.518 raeburn 8343: sub check_internal_passwd {
1.533 raeburn 8344: my ($plainpass,$stored,$domain,$user) = @_;
1.518 raeburn 8345: my (undef,$method,@rest) = split(/!/,$stored);
1.533 raeburn 8346: if ($method eq 'bcrypt') {
1.518 raeburn 8347: my $result = &hash_passwd($domain,$plainpass,@rest);
8348: if ($result ne $stored) {
8349: return 0;
8350: }
1.533 raeburn 8351: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
8352: if ($domdefaults{'intauth_check'}) {
8353: # Upgrade to a larger number of rounds if necessary
8354: my $defaultcost = $domdefaults{'intauth_cost'};
8355: if (($defaultcost eq '') || ($defaultcost =~ /D/)) {
8356: $defaultcost = 10;
8357: }
8358: if (int($rest[0])<int($defaultcost)) {
8359: if ($domdefaults{'intauth_check'} == 1) {
8360: my $ncpass = &hash_passwd($domain,$plainpass);
8361: if (&rewrite_password_file($domain,$user,"internal:$ncpass")) {
8362: &update_passwd_history($user,$domain,'internal','update cost');
8363: &logthis("Validated password hashed with bcrypt for $user:$domain");
8364: }
8365: return 1;
8366: } elsif ($domdefaults{'intauth_check'} == 2) {
8367: return 0;
8368: }
8369: }
8370: } else {
8371: return 1;
1.518 raeburn 8372: }
8373: }
8374: return 0;
8375: }
8376:
8377: sub get_last_authchg {
8378: my ($domain,$user) = @_;
8379: my $lastmod;
8380: my $logname = &propath($domain,$user).'/passwd.log';
8381: if (-e "$logname") {
8382: $lastmod = (stat("$logname"))[9];
8383: }
8384: return $lastmod;
8385: }
8386:
1.439 raeburn 8387: sub krb4_authen {
8388: my ($password,$null,$user,$contentpwd) = @_;
8389: my $validated = 0;
8390: if (!($password =~ /$null/) ) { # Null password not allowed.
8391: eval {
8392: require Authen::Krb4;
8393: };
8394: if (!$@) {
8395: my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
8396: "",
8397: $contentpwd,,
8398: 'krbtgt',
8399: $contentpwd,
8400: 1,
8401: $password);
8402: if(!$k4error) {
8403: $validated = 1;
8404: } else {
8405: $validated = 0;
8406: &logthis('krb4: '.$user.', '.$contentpwd.', '.
8407: &Authen::Krb4::get_err_txt($Authen::Krb4::error));
8408: }
8409: } else {
8410: $validated = krb5_authen($password,$null,$user,$contentpwd);
8411: }
8412: }
8413: return $validated;
8414: }
8415:
8416: sub krb5_authen {
8417: my ($password,$null,$user,$contentpwd) = @_;
8418: my $validated = 0;
8419: if(!($password =~ /$null/)) { # Null password not allowed.
8420: my $krbclient = &Authen::Krb5::parse_name($user.'@'
8421: .$contentpwd);
8422: my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
8423: my $krbserver = &Authen::Krb5::parse_name($krbservice);
8424: my $credentials= &Authen::Krb5::cc_default();
8425: $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
8426: .$contentpwd));
8427: my $krbreturn;
8428: if (exists(&Authen::Krb5::get_init_creds_password)) {
8429: $krbreturn =
8430: &Authen::Krb5::get_init_creds_password($krbclient,$password,
8431: $krbservice);
8432: $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
8433: } else {
8434: $krbreturn =
8435: &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
8436: $password,$credentials);
8437: $validated = ($krbreturn == 1);
8438: }
8439: if (!$validated) {
8440: &logthis('krb5: '.$user.', '.$contentpwd.', '.
8441: &Authen::Krb5::error());
8442: }
8443: }
8444: return $validated;
8445: }
1.220 foxr 8446:
1.84 albertel 8447: sub addline {
8448: my ($fname,$hostid,$ip,$newline)=@_;
8449: my $contents;
8450: my $found=0;
1.355 albertel 8451: my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':';
1.134 albertel 8452: my $sh;
1.84 albertel 8453: if ($sh=IO::File->new("$fname.subscription")) {
8454: while (my $subline=<$sh>) {
8455: if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
8456: }
8457: $sh->close();
8458: }
8459: $sh=IO::File->new(">$fname.subscription");
8460: if ($contents) { print $sh $contents; }
8461: if ($newline) { print $sh $newline; }
8462: $sh->close();
8463: return $found;
1.86 www 8464: }
8465:
1.234 foxr 8466: sub get_chat {
1.324 raeburn 8467: my ($cdom,$cname,$udom,$uname,$group)=@_;
1.310 albertel 8468:
1.87 www 8469: my @entries=();
1.324 raeburn 8470: my $namespace = 'nohist_chatroom';
8471: my $namespace_inroom = 'nohist_inchatroom';
1.335 albertel 8472: if ($group ne '') {
1.324 raeburn 8473: $namespace .= '_'.$group;
8474: $namespace_inroom .= '_'.$group;
8475: }
8476: my $hashref = &tie_user_hash($cdom, $cname, $namespace,
1.310 albertel 8477: &GDBM_READER());
8478: if ($hashref) {
8479: @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
1.311 albertel 8480: &untie_user_hash($hashref);
1.123 www 8481: }
1.124 www 8482: my @participants=();
1.134 albertel 8483: my $cutoff=time-60;
1.324 raeburn 8484: $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom,
1.310 albertel 8485: &GDBM_WRCREAT());
8486: if ($hashref) {
8487: $hashref->{$uname.':'.$udom}=time;
8488: foreach my $user (sort(keys(%$hashref))) {
8489: if ($hashref->{$user}>$cutoff) {
8490: push(@participants, 'active_participant:'.$user);
1.123 www 8491: }
8492: }
1.311 albertel 8493: &untie_user_hash($hashref);
1.86 www 8494: }
1.124 www 8495: return (@participants,@entries);
1.86 www 8496: }
8497:
1.234 foxr 8498: sub chat_add {
1.324 raeburn 8499: my ($cdom,$cname,$newchat,$group)=@_;
1.88 albertel 8500: my @entries=();
1.142 www 8501: my $time=time;
1.324 raeburn 8502: my $namespace = 'nohist_chatroom';
8503: my $logfile = 'chatroom.log';
1.335 albertel 8504: if ($group ne '') {
1.324 raeburn 8505: $namespace .= '_'.$group;
8506: $logfile = 'chatroom_'.$group.'.log';
8507: }
8508: my $hashref = &tie_user_hash($cdom, $cname, $namespace,
1.310 albertel 8509: &GDBM_WRCREAT());
8510: if ($hashref) {
8511: @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
1.88 albertel 8512: my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
8513: my ($thentime,$idnum)=split(/\_/,$lastid);
8514: my $newid=$time.'_000000';
8515: if ($thentime==$time) {
8516: $idnum=~s/^0+//;
8517: $idnum++;
8518: $idnum=substr('000000'.$idnum,-6,6);
8519: $newid=$time.'_'.$idnum;
8520: }
1.310 albertel 8521: $hashref->{$newid}=$newchat;
1.88 albertel 8522: my $expired=$time-3600;
1.310 albertel 8523: foreach my $comment (keys(%$hashref)) {
8524: my ($thistime) = ($comment=~/(\d+)\_/);
1.88 albertel 8525: if ($thistime<$expired) {
1.310 albertel 8526: delete $hashref->{$comment};
1.88 albertel 8527: }
8528: }
1.310 albertel 8529: {
8530: my $proname=&propath($cdom,$cname);
1.324 raeburn 8531: if (open(CHATLOG,">>$proname/$logfile")) {
1.310 albertel 8532: print CHATLOG ("$time:".&unescape($newchat)."\n");
8533: }
8534: close(CHATLOG);
1.142 www 8535: }
1.311 albertel 8536: &untie_user_hash($hashref);
1.86 www 8537: }
1.84 albertel 8538: }
8539:
8540: sub unsub {
8541: my ($fname,$clientip)=@_;
8542: my $result;
1.188 foxr 8543: my $unsubs = 0; # Number of successful unsubscribes:
8544:
8545:
8546: # An old way subscriptions were handled was to have a
8547: # subscription marker file:
8548:
8549: Debug("Attempting unlink of $fname.$clientname");
1.161 foxr 8550: if (unlink("$fname.$clientname")) {
1.188 foxr 8551: $unsubs++; # Successful unsub via marker file.
8552: }
8553:
8554: # The more modern way to do it is to have a subscription list
8555: # file:
8556:
1.84 albertel 8557: if (-e "$fname.subscription") {
1.161 foxr 8558: my $found=&addline($fname,$clientname,$clientip,'');
1.188 foxr 8559: if ($found) {
8560: $unsubs++;
8561: }
8562: }
8563:
8564: # If either or both of these mechanisms succeeded in unsubscribing a
8565: # resource we can return ok:
8566:
8567: if($unsubs) {
8568: $result = "ok\n";
1.84 albertel 8569: } else {
1.188 foxr 8570: $result = "not_subscribed\n";
1.84 albertel 8571: }
1.188 foxr 8572:
1.84 albertel 8573: return $result;
8574: }
8575:
1.101 www 8576: sub currentversion {
8577: my $fname=shift;
8578: my $version=-1;
8579: my $ulsdir='';
8580: if ($fname=~/^(.+)\/[^\/]+$/) {
8581: $ulsdir=$1;
8582: }
1.114 albertel 8583: my ($fnamere1,$fnamere2);
8584: # remove version if already specified
1.101 www 8585: $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
1.114 albertel 8586: # get the bits that go before and after the version number
8587: if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
8588: $fnamere1=$1;
8589: $fnamere2='.'.$2;
8590: }
1.101 www 8591: if (-e $fname) { $version=1; }
8592: if (-e $ulsdir) {
1.134 albertel 8593: if(-d $ulsdir) {
8594: if (opendir(LSDIR,$ulsdir)) {
8595: my $ulsfn;
8596: while ($ulsfn=readdir(LSDIR)) {
1.101 www 8597: # see if this is a regular file (ignore links produced earlier)
1.134 albertel 8598: my $thisfile=$ulsdir.'/'.$ulsfn;
8599: unless (-l $thisfile) {
1.160 www 8600: if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) {
1.134 albertel 8601: if ($1>$version) { $version=$1; }
8602: }
8603: }
8604: }
8605: closedir(LSDIR);
8606: $version++;
8607: }
8608: }
8609: }
8610: return $version;
1.101 www 8611: }
8612:
8613: sub thisversion {
8614: my $fname=shift;
8615: my $version=-1;
8616: if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
8617: $version=$1;
8618: }
8619: return $version;
8620: }
8621:
1.84 albertel 8622: sub subscribe {
8623: my ($userinput,$clientip)=@_;
8624: my $result;
1.293 albertel 8625: my ($cmd,$fname)=split(/:/,$userinput,2);
1.84 albertel 8626: my $ownership=&ishome($fname);
8627: if ($ownership eq 'owner') {
1.101 www 8628: # explitly asking for the current version?
8629: unless (-e $fname) {
8630: my $currentversion=¤tversion($fname);
8631: if (&thisversion($fname)==$currentversion) {
8632: if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
8633: my $root=$1;
8634: my $extension=$2;
8635: symlink($root.'.'.$extension,
8636: $root.'.'.$currentversion.'.'.$extension);
1.102 www 8637: unless ($extension=~/\.meta$/) {
8638: symlink($root.'.'.$extension.'.meta',
8639: $root.'.'.$currentversion.'.'.$extension.'.meta');
8640: }
1.101 www 8641: }
8642: }
8643: }
1.84 albertel 8644: if (-e $fname) {
8645: if (-d $fname) {
8646: $result="directory\n";
8647: } else {
1.161 foxr 8648: if (-e "$fname.$clientname") {&unsub($fname,$clientip);}
1.134 albertel 8649: my $now=time;
1.161 foxr 8650: my $found=&addline($fname,$clientname,$clientip,
8651: "$clientname:$clientip:$now\n");
1.84 albertel 8652: if ($found) { $result="$fname\n"; }
8653: # if they were subscribed to only meta data, delete that
8654: # subscription, when you subscribe to a file you also get
8655: # the metadata
8656: unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
8657: $fname=~s/\/home\/httpd\/html\/res/raw/;
1.476 raeburn 8658: my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}};
8659: $protocol = 'http' if ($protocol ne 'https');
8660: $fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
1.84 albertel 8661: $result="$fname\n";
8662: }
8663: } else {
8664: $result="not_found\n";
8665: }
8666: } else {
8667: $result="rejected\n";
8668: }
8669: return $result;
8670: }
1.287 foxr 8671: # Change the passwd of a unix user. The caller must have
8672: # first verified that the user is a loncapa user.
8673: #
8674: # Parameters:
8675: # user - Unix user name to change.
8676: # pass - New password for the user.
8677: # Returns:
8678: # ok - if success
8679: # other - Some meaningfule error message string.
8680: # NOTE:
8681: # invokes a setuid script to change the passwd.
8682: sub change_unix_password {
8683: my ($user, $pass) = @_;
8684:
8685: &Debug("change_unix_password");
8686: my $execdir=$perlvar{'lonDaemons'};
8687: &Debug("Opening lcpasswd pipeline");
8688: my $pf = IO::File->new("|$execdir/lcpasswd > "
8689: ."$perlvar{'lonDaemons'}"
8690: ."/logs/lcpasswd.log");
8691: print $pf "$user\n$pass\n$pass\n";
8692: close $pf;
8693: my $err = $?;
8694: return ($err < @passwderrors) ? $passwderrors[$err] :
8695: "pwchange_falure - unknown error";
8696:
8697:
8698: }
8699:
1.91 albertel 8700:
8701: sub make_passwd_file {
1.518 raeburn 8702: my ($uname,$udom,$umode,$npass,$passfilename,$action)=@_;
1.390 raeburn 8703: my $result="ok";
1.91 albertel 8704: if ($umode eq 'krb4' or $umode eq 'krb5') {
8705: {
8706: my $pf = IO::File->new(">$passfilename");
1.261 foxr 8707: if ($pf) {
8708: print $pf "$umode:$npass\n";
1.518 raeburn 8709: &update_passwd_history($uname,$udom,$umode,$action);
1.261 foxr 8710: } else {
8711: $result = "pass_file_failed_error";
8712: }
1.91 albertel 8713: }
8714: } elsif ($umode eq 'internal') {
1.518 raeburn 8715: my $ncpass = &hash_passwd($udom,$npass);
1.91 albertel 8716: {
8717: &Debug("Creating internal auth");
8718: my $pf = IO::File->new(">$passfilename");
1.261 foxr 8719: if($pf) {
1.518 raeburn 8720: print $pf "internal:$ncpass\n";
8721: &update_passwd_history($uname,$udom,$umode,$action);
1.261 foxr 8722: } else {
8723: $result = "pass_file_failed_error";
8724: }
1.91 albertel 8725: }
8726: } elsif ($umode eq 'localauth') {
8727: {
8728: my $pf = IO::File->new(">$passfilename");
1.261 foxr 8729: if($pf) {
8730: print $pf "localauth:$npass\n";
1.524 raeburn 8731: &update_passwd_history($uname,$udom,$umode,$action);
1.261 foxr 8732: } else {
8733: $result = "pass_file_failed_error";
8734: }
1.91 albertel 8735: }
8736: } elsif ($umode eq 'unix') {
1.502 raeburn 8737: &logthis(">>>Attempt to create unix account blocked -- unix auth not available for new users.");
8738: $result="no_new_unix_accounts";
1.91 albertel 8739: } elsif ($umode eq 'none') {
8740: {
1.223 foxr 8741: my $pf = IO::File->new("> $passfilename");
1.261 foxr 8742: if($pf) {
8743: print $pf "none:\n";
8744: } else {
8745: $result = "pass_file_failed_error";
8746: }
1.91 albertel 8747: }
1.543 raeburn 8748: } elsif ($umode eq 'lti') {
8749: my $pf = IO::File->new(">$passfilename");
8750: if($pf) {
8751: print $pf "lti:\n";
8752: &update_passwd_history($uname,$udom,$umode,$action);
8753: } else {
8754: $result = "pass_file_failed_error";
8755: }
1.91 albertel 8756: } else {
1.390 raeburn 8757: $result="auth_mode_error";
1.91 albertel 8758: }
8759: return $result;
1.121 albertel 8760: }
8761:
1.265 albertel 8762: sub convert_photo {
8763: my ($start,$dest)=@_;
8764: system("convert $start $dest");
8765: }
8766:
1.121 albertel 8767: sub sethost {
8768: my ($remotereq) = @_;
8769: my (undef,$hostid)=split(/:/,$remotereq);
1.322 albertel 8770: # ignore sethost if we are already correct
8771: if ($hostid eq $currenthostid) {
8772: return 'ok';
8773: }
8774:
1.121 albertel 8775: if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
1.368 albertel 8776: if (&Apache::lonnet::get_host_ip($perlvar{'lonHostID'})
8777: eq &Apache::lonnet::get_host_ip($hostid)) {
1.200 matthew 8778: $currenthostid =$hostid;
1.369 albertel 8779: $currentdomainid=&Apache::lonnet::host_domain($hostid);
1.556 raeburn 8780: &set_client_info();
1.443 www 8781: # &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
1.121 albertel 8782: } else {
8783: &logthis("Requested host id $hostid not an alias of ".
8784: $perlvar{'lonHostID'}." refusing connection");
8785: return 'unable_to_set';
8786: }
8787: return 'ok';
8788: }
8789:
8790: sub version {
8791: my ($userinput)=@_;
8792: $remoteVERSION=(split(/:/,$userinput))[1];
8793: return "version:$VERSION";
1.127 albertel 8794: }
1.178 foxr 8795:
1.447 raeburn 8796: sub get_usersession_config {
8797: my ($dom,$name) = @_;
8798: my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
8799: if (defined($cached)) {
8800: return $usersessionconf;
8801: } else {
8802: my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
1.525 raeburn 8803: &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
8804: return $domconfig{'usersessions'};
1.447 raeburn 8805: }
8806: return;
8807: }
1.200 matthew 8808:
1.534 raeburn 8809: sub get_usersearch_config {
8810: my ($dom,$name) = @_;
8811: my ($usersearchconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
8812: if (defined($cached)) {
8813: return $usersearchconf;
8814: } else {
8815: my %domconfig = &Apache::lonnet::get_dom('configuration',['directorysrch'],$dom);
8816: &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'directorysrch'},600);
8817: return $domconfig{'directorysrch'};
8818: }
8819: return;
8820: }
8821:
1.525 raeburn 8822: sub get_prohibited {
8823: my ($dom) = @_;
8824: my $name = 'trust';
8825: my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
8826: unless (defined($cached)) {
8827: my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$dom);
8828: &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'trust'},3600);
8829: $trustconfig = $domconfig{'trust'};
8830: }
8831: my %prohibited;
8832: if (ref($trustconfig)) {
8833: foreach my $prefix (keys(%{$trustconfig})) {
8834: if (ref($trustconfig->{$prefix}) eq 'HASH') {
8835: my $reject;
8836: if (ref($trustconfig->{$prefix}->{'exc'}) eq 'ARRAY') {
8837: if (grep(/^\Q$clientintdom\E$/,@{$trustconfig->{$prefix}->{'exc'}})) {
8838: $reject = 1;
8839: }
8840: }
8841: if (ref($trustconfig->{$prefix}->{'inc'}) eq 'ARRAY') {
8842: if (grep(/^\Q$clientintdom\E$/,@{$trustconfig->{$prefix}->{'inc'}})) {
8843: $reject = 0;
8844: } else {
8845: $reject = 1;
8846: }
8847: }
8848: if ($reject) {
8849: $prohibited{$prefix} = 1;
8850: }
8851: }
8852: }
8853: }
8854: return %prohibited;
8855: }
1.450 raeburn 8856:
1.556 raeburn 8857: sub get_remote_hostable {
8858: my ($dom) = @_;
8859: my $result;
8860: if ($clientintdom) {
8861: $result = 1;
8862: my $remsessconf = &get_usersession_config($dom,'remotesession');
8863: if (ref($remsessconf) eq 'HASH') {
8864: if (ref($remsessconf->{'remote'}) eq 'HASH') {
8865: if (ref($remsessconf->{'remote'}->{'excludedomain'}) eq 'ARRAY') {
8866: if (grep(/^\Q$clientintdom\E$/,@{$remsessconf->{'remote'}->{'excludedomain'}})) {
8867: $result = 0;
8868: }
8869: }
8870: if (ref($remsessconf->{'remote'}->{'includedomain'}) eq 'ARRAY') {
8871: if (grep(/^\Q$clientintdom\E$/,@{$remsessconf->{'remote'}->{'includedomain'}})) {
8872: $result = 1;
8873: } else {
8874: $result = 0;
8875: }
8876: }
8877: }
8878: }
8879: }
8880: return $result;
8881: }
8882:
1.471 raeburn 8883: sub distro_and_arch {
8884: return $dist.':'.$arch;
8885: }
8886:
1.61 harris41 8887: # ----------------------------------- POD (plain old documentation, CPAN style)
8888:
8889: =head1 NAME
8890:
8891: lond - "LON Daemon" Server (port "LOND" 5663)
8892:
8893: =head1 SYNOPSIS
8894:
1.74 harris41 8895: Usage: B<lond>
8896:
8897: Should only be run as user=www. This is a command-line script which
8898: is invoked by B<loncron>. There is no expectation that a typical user
8899: will manually start B<lond> from the command-line. (In other words,
8900: DO NOT START B<lond> YOURSELF.)
1.61 harris41 8901:
8902: =head1 DESCRIPTION
8903:
1.74 harris41 8904: There are two characteristics associated with the running of B<lond>,
8905: PROCESS MANAGEMENT (starting, stopping, handling child processes)
8906: and SERVER-SIDE ACTIVITIES (password authentication, user creation,
8907: subscriptions, etc). These are described in two large
8908: sections below.
8909:
8910: B<PROCESS MANAGEMENT>
8911:
1.61 harris41 8912: Preforker - server who forks first. Runs as a daemon. HUPs.
8913: Uses IDEA encryption
8914:
1.74 harris41 8915: B<lond> forks off children processes that correspond to the other servers
8916: in the network. Management of these processes can be done at the
8917: parent process level or the child process level.
8918:
8919: B<logs/lond.log> is the location of log messages.
8920:
8921: The process management is now explained in terms of linux shell commands,
8922: subroutines internal to this code, and signal assignments:
8923:
8924: =over 4
8925:
8926: =item *
8927:
8928: PID is stored in B<logs/lond.pid>
8929:
8930: This is the process id number of the parent B<lond> process.
8931:
8932: =item *
8933:
8934: SIGTERM and SIGINT
8935:
8936: Parent signal assignment:
8937: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
8938:
8939: Child signal assignment:
8940: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
8941: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
8942: to restart a new child.)
8943:
8944: Command-line invocations:
8945: B<kill> B<-s> SIGTERM I<PID>
8946: B<kill> B<-s> SIGINT I<PID>
8947:
8948: Subroutine B<HUNTSMAN>:
8949: This is only invoked for the B<lond> parent I<PID>.
8950: This kills all the children, and then the parent.
8951: The B<lonc.pid> file is cleared.
8952:
8953: =item *
8954:
8955: SIGHUP
8956:
8957: Current bug:
8958: This signal can only be processed the first time
8959: on the parent process. Subsequent SIGHUP signals
8960: have no effect.
8961:
8962: Parent signal assignment:
8963: $SIG{HUP} = \&HUPSMAN;
8964:
8965: Child signal assignment:
8966: none (nothing happens)
8967:
8968: Command-line invocations:
8969: B<kill> B<-s> SIGHUP I<PID>
8970:
8971: Subroutine B<HUPSMAN>:
8972: This is only invoked for the B<lond> parent I<PID>,
8973: This kills all the children, and then the parent.
8974: The B<lond.pid> file is cleared.
8975:
8976: =item *
8977:
8978: SIGUSR1
8979:
8980: Parent signal assignment:
8981: $SIG{USR1} = \&USRMAN;
8982:
8983: Child signal assignment:
8984: $SIG{USR1}= \&logstatus;
8985:
8986: Command-line invocations:
8987: B<kill> B<-s> SIGUSR1 I<PID>
8988:
8989: Subroutine B<USRMAN>:
8990: When invoked for the B<lond> parent I<PID>,
8991: SIGUSR1 is sent to all the children, and the status of
8992: each connection is logged.
1.144 foxr 8993:
8994: =item *
8995:
8996: SIGUSR2
8997:
8998: Parent Signal assignment:
8999: $SIG{USR2} = \&UpdateHosts
9000:
9001: Child signal assignment:
9002: NONE
9003:
1.74 harris41 9004:
9005: =item *
9006:
9007: SIGCHLD
9008:
9009: Parent signal assignment:
9010: $SIG{CHLD} = \&REAPER;
9011:
9012: Child signal assignment:
9013: none
9014:
9015: Command-line invocations:
9016: B<kill> B<-s> SIGCHLD I<PID>
9017:
9018: Subroutine B<REAPER>:
9019: This is only invoked for the B<lond> parent I<PID>.
9020: Information pertaining to the child is removed.
9021: The socket port is cleaned up.
9022:
9023: =back
9024:
9025: B<SERVER-SIDE ACTIVITIES>
9026:
9027: Server-side information can be accepted in an encrypted or non-encrypted
9028: method.
9029:
9030: =over 4
9031:
9032: =item ping
9033:
9034: Query a client in the hosts.tab table; "Are you there?"
9035:
9036: =item pong
9037:
9038: Respond to a ping query.
9039:
9040: =item ekey
9041:
9042: Read in encrypted key, make cipher. Respond with a buildkey.
9043:
9044: =item load
9045:
9046: Respond with CPU load based on a computation upon /proc/loadavg.
9047:
9048: =item currentauth
9049:
9050: Reply with current authentication information (only over an
9051: encrypted channel).
9052:
9053: =item auth
9054:
9055: Only over an encrypted channel, reply as to whether a user's
9056: authentication information can be validated.
9057:
9058: =item passwd
9059:
9060: Allow for a password to be set.
9061:
9062: =item makeuser
9063:
9064: Make a user.
9065:
1.517 raeburn 9066: =item changeuserauth
1.74 harris41 9067:
9068: Allow for authentication mechanism and password to be changed.
9069:
9070: =item home
1.61 harris41 9071:
1.74 harris41 9072: Respond to a question "are you the home for a given user?"
9073:
9074: =item update
9075:
9076: Update contents of a subscribed resource.
9077:
9078: =item unsubscribe
9079:
9080: The server is unsubscribing from a resource.
9081:
9082: =item subscribe
9083:
9084: The server is subscribing to a resource.
9085:
9086: =item log
9087:
9088: Place in B<logs/lond.log>
9089:
9090: =item put
9091:
9092: stores hash in namespace
9093:
1.496 raeburn 9094: =item rolesput
1.74 harris41 9095:
9096: put a role into a user's environment
9097:
9098: =item get
9099:
9100: returns hash with keys from array
9101: reference filled in from namespace
9102:
9103: =item eget
9104:
9105: returns hash with keys from array
9106: reference filled in from namesp (encrypts the return communication)
9107:
9108: =item rolesget
9109:
9110: get a role from a user's environment
9111:
9112: =item del
9113:
9114: deletes keys out of array from namespace
9115:
9116: =item keys
9117:
9118: returns namespace keys
9119:
9120: =item dump
9121:
9122: dumps the complete (or key matching regexp) namespace into a hash
9123:
9124: =item store
9125:
9126: stores hash permanently
9127: for this url; hashref needs to be given and should be a \%hashname; the
9128: remaining args aren't required and if they aren't passed or are '' they will
9129: be derived from the ENV
9130:
9131: =item restore
9132:
9133: returns a hash for a given url
9134:
9135: =item querysend
9136:
9137: Tells client about the lonsql process that has been launched in response
9138: to a sent query.
9139:
9140: =item queryreply
9141:
9142: Accept information from lonsql and make appropriate storage in temporary
9143: file space.
9144:
9145: =item idput
9146:
9147: Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers
9148: for each student, defined perhaps by the institutional Registrar.)
9149:
9150: =item idget
9151:
9152: Returns usernames corresponding to IDs. (These "IDs" are unique identifiers
9153: for each student, defined perhaps by the institutional Registrar.)
9154:
1.517 raeburn 9155: =item iddel
9156:
9157: Deletes one or more ids in a domain's id database.
9158:
1.74 harris41 9159: =item tmpput
9160:
9161: Accept and store information in temporary space.
9162:
9163: =item tmpget
9164:
9165: Send along temporarily stored information.
9166:
9167: =item ls
9168:
9169: List part of a user's directory.
9170:
1.135 foxr 9171: =item pushtable
9172:
9173: Pushes a file in /home/httpd/lonTab directory. Currently limited to:
9174: hosts.tab and domain.tab. The old file is copied to *.tab.backup but
9175: must be restored manually in case of a problem with the new table file.
9176: pushtable requires that the request be encrypted and validated via
9177: ValidateManager. The form of the command is:
9178: enc:pushtable tablename <tablecontents> \n
9179: where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
9180: cleartext newline.
9181:
1.74 harris41 9182: =item Hanging up (exit or init)
9183:
9184: What to do when a client tells the server that they (the client)
9185: are leaving the network.
9186:
9187: =item unknown command
9188:
9189: If B<lond> is sent an unknown command (not in the list above),
9190: it replys to the client "unknown_cmd".
1.135 foxr 9191:
1.74 harris41 9192:
9193: =item UNKNOWN CLIENT
9194:
9195: If the anti-spoofing algorithm cannot verify the client,
9196: the client is rejected (with a "refused" message sent
9197: to the client, and the connection is closed.
9198:
9199: =back
1.61 harris41 9200:
9201: =head1 PREREQUISITES
9202:
9203: IO::Socket
9204: IO::File
9205: Apache::File
9206: POSIX
9207: Crypt::IDEA
9208: GDBM_File
9209: Authen::Krb4
1.91 albertel 9210: Authen::Krb5
1.61 harris41 9211:
9212: =head1 COREQUISITES
9213:
1.490 droeschl 9214: none
9215:
1.61 harris41 9216: =head1 OSNAMES
9217:
9218: linux
9219:
9220: =head1 SCRIPT CATEGORIES
9221:
9222: Server/Process
9223:
9224: =cut
1.409 foxr 9225:
9226:
9227: =pod
9228:
9229: =head1 LOG MESSAGES
9230:
9231: The messages below can be emitted in the lond log. This log is located
9232: in ~httpd/perl/logs/lond.log Many log messages have HTML encapsulation
9233: to provide coloring if examined from inside a web page. Some do not.
9234: Where color is used, the colors are; Red for sometihhng to get excited
9235: about and to follow up on. Yellow for something to keep an eye on to
9236: be sure it does not get worse, Green,and Blue for informational items.
9237:
9238: In the discussions below, sometimes reference is made to ~httpd
9239: when describing file locations. There isn't really an httpd
9240: user, however there is an httpd directory that gets installed in the
9241: place that user home directories go. On linux, this is usually
9242: (always?) /home/httpd.
9243:
9244:
9245: Some messages are colorless. These are usually (not always)
9246: Green/Blue color level messages.
9247:
9248: =over 2
9249:
9250: =item (Red) LocalConnection rejecting non local: <ip> ne 127.0.0.1
9251:
9252: A local connection negotiation was attempted by
9253: a host whose IP address was not 127.0.0.1.
9254: The socket is closed and the child will exit.
9255: lond has three ways to establish an encyrption
9256: key with a client:
9257:
9258: =over 2
9259:
9260: =item local
9261:
9262: The key is written and read from a file.
9263: This is only valid for connections from localhost.
9264:
9265: =item insecure
9266:
9267: The key is generated by the server and
9268: transmitted to the client.
9269:
9270: =item ssl (secure)
9271:
9272: An ssl connection is negotiated with the client,
9273: the key is generated by the server and sent to the
9274: client across this ssl connection before the
9275: ssl connectionis terminated and clear text
9276: transmission resumes.
9277:
9278: =back
9279:
9280: =item (Red) LocalConnection: caller is insane! init = <init> and type = <type>
9281:
9282: The client is local but has not sent an initialization
9283: string that is the literal "init:local" The connection
9284: is closed and the child exits.
9285:
9286: =item Red CRITICAL Can't get key file <error>
9287:
9288: SSL key negotiation is being attempted but the call to
1.549 raeburn 9289: lonssl::KeyFile failed. This usually means that the
1.409 foxr 9290: configuration file is not correctly defining or protecting
9291: the directories/files lonCertificateDirectory or
9292: lonnetPrivateKey
9293: <error> is a string that describes the reason that
9294: the key file could not be located.
9295:
9296: =item (Red) CRITICAL Can't get certificates <error>
9297:
9298: SSL key negotiation failed because we were not able to retrives our certificate
9299: or the CA's certificate in the call to lonssl::CertificateFile
9300: <error> is the textual reason this failed. Usual reasons:
9301:
9302: =over 2
1.490 droeschl 9303:
1.409 foxr 9304: =item Apache config file for loncapa incorrect:
1.490 droeschl 9305:
1.409 foxr 9306: one of the variables
9307: lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate
9308: undefined or incorrect
9309:
9310: =item Permission error:
9311:
9312: The directory pointed to by lonCertificateDirectory is not readable by lond
9313:
9314: =item Permission error:
9315:
9316: Files in the directory pointed to by lonCertificateDirectory are not readable by lond.
9317:
9318: =item Installation error:
9319:
9320: Either the certificate authority file or the certificate have not
9321: been installed in lonCertificateDirectory.
9322:
9323: =item (Red) CRITICAL SSL Socket promotion failed: <err>
9324:
9325: The promotion of the connection from plaintext to SSL failed
9326: <err> is the reason for the failure. There are two
9327: system calls involved in the promotion (one of which failed),
9328: a dup to produce
9329: a second fd on the raw socket over which the encrypted data
9330: will flow and IO::SOcket::SSL->new_from_fd which creates
9331: the SSL connection on the duped fd.
9332:
9333: =item (Blue) WARNING client did not respond to challenge
9334:
9335: This occurs on an insecure (non SSL) connection negotiation request.
9336: lond generates some number from the time, the PID and sends it to
9337: the client. The client must respond by echoing this information back.
9338: If the client does not do so, that's a violation of the challenge
9339: protocols and the connection will be failed.
9340:
9341: =item (Red) No manager table. Nobody can manage!!
9342:
9343: lond has the concept of privileged hosts that
9344: can perform remote management function such
9345: as update the hosts.tab. The manager hosts
9346: are described in the
9347: ~httpd/lonTabs/managers.tab file.
9348: this message is logged if this file is missing.
9349:
9350:
9351: =item (Green) Registering manager <dnsname> as <cluster_name> with <ipaddress>
9352:
9353: Reports the successful parse and registration
9354: of a specific manager.
9355:
9356: =item Green existing host <clustername:dnsname>
9357:
9358: The manager host is already defined in the hosts.tab
9359: the information in that table, rather than the info in the
9360: manager table will be used to determine the manager's ip.
9361:
9362: =item (Red) Unable to craete <filename>
9363:
9364: lond has been asked to create new versions of an administrative
9365: file (by a manager). When this is done, the new file is created
9366: in a temp file and then renamed into place so that there are always
9367: usable administrative files, even if the update fails. This failure
9368: message means that the temp file could not be created.
9369: The update is abandoned, and the old file is available for use.
9370:
9371: =item (Green) CopyFile from <oldname> to <newname> failed
9372:
9373: In an update of administrative files, the copy of the existing file to a
9374: backup file failed. The installation of the new file may still succeed,
9375: but there will not be a back up file to rever to (this should probably
9376: be yellow).
9377:
9378: =item (Green) Pushfile: backed up <oldname> to <newname>
9379:
9380: See above, the backup of the old administrative file succeeded.
9381:
9382: =item (Red) Pushfile: Unable to install <filename> <reason>
9383:
9384: The new administrative file could not be installed. In this case,
9385: the old administrative file is still in use.
9386:
9387: =item (Green) Installed new < filename>.
9388:
9389: The new administrative file was successfullly installed.
9390:
9391: =item (Red) Reinitializing lond pid=<pid>
9392:
9393: The lonc child process <pid> will be sent a USR2
9394: signal.
9395:
9396: =item (Red) Reinitializing self
9397:
9398: We've been asked to re-read our administrative files,and
9399: are doing so.
9400:
9401: =item (Yellow) error:Invalid process identifier <ident>
9402:
9403: A reinit command was received, but the target part of the
9404: command was not valid. It must be either
9405: 'lond' or 'lonc' but was <ident>
9406:
9407: =item (Green) isValideditCommand checking: Command = <command> Key = <key> newline = <newline>
9408:
9409: Checking to see if lond has been handed a valid edit
9410: command. It is possible the edit command is not valid
9411: in that case there are no log messages to indicate that.
9412:
9413: =item Result of password change for <username> pwchange_success
9414:
9415: The password for <username> was
9416: successfully changed.
9417:
9418: =item Unable to open <user> passwd to change password
9419:
9420: Could not rewrite the
9421: internal password file for a user
9422:
9423: =item Result of password change for <user> : <result>
1.490 droeschl 9424:
1.409 foxr 9425: A unix password change for <user> was attempted
9426: and the pipe returned <result>
9427:
9428: =item LWP GET: <message> for <fname> (<remoteurl>)
9429:
9430: The lightweight process fetch for a resource failed
9431: with <message> the local filename that should
9432: have existed/been created was <fname> the
9433: corresponding URI: <remoteurl> This is emitted in several
9434: places.
9435:
9436: =item Unable to move <transname> to <destname>
9437:
9438: From fetch_user_file_handler - the user file was replicated but could not
9439: be mv'd to its final location.
9440:
9441: =item Looking for <domain> <username>
9442:
9443: From user_has_session_handler - This should be a Debug call instead
9444: it indicates lond is about to check whether the specified user has a
9445: session active on the specified domain on the local host.
9446:
9447: =item Client <ip> (<name>) hanging up: <input>
9448:
9449: lond has been asked to exit by its client. The <ip> and <name> identify the
9450: client systemand <input> is the full exit command sent to the server.
9451:
9452: =item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].
1.490 droeschl 9453:
1.409 foxr 9454: A lond child terminated. NOte that this termination can also occur when the
9455: child receives the QUIT or DIE signals. <pid> is the process id of the child,
9456: <hostname> the host lond is working for, and <message> the reason the child died
9457: to the best of our ability to get it (I would guess that any numeric value
9458: represents and errno value). This is immediately followed by
9459:
9460: =item Famous last words: Catching exception - <log>
9461:
9462: Where log is some recent information about the state of the child.
9463:
9464: =item Red CRITICAL: TIME OUT <pid>
9465:
9466: Some timeout occured for server <pid>. THis is normally a timeout on an LWP
9467: doing an HTTP::GET.
9468:
9469: =item child <pid> died
9470:
9471: The reaper caught a SIGCHILD for the lond child process <pid>
9472: This should be modified to also display the IP of the dying child
9473: $children{$pid}
9474:
9475: =item Unknown child 0 died
9476: A child died but the wait for it returned a pid of zero which really should not
9477: ever happen.
9478:
9479: =item Child <which> - <pid> looks like we missed it's death
9480:
9481: When a sigchild is received, the reaper process checks all children to see if they are
9482: alive. If children are dying quite quickly, the lack of signal queuing can mean
9483: that a signal hearalds the death of more than one child. If so this message indicates
9484: which other one died. <which> is the ip of a dead child
9485:
9486: =item Free socket: <shutdownretval>
9487:
9488: The HUNTSMAN sub was called due to a SIGINT in a child process. The socket is being shutdown.
9489: for whatever reason, <shutdownretval> is printed but in fact shutdown() is not documented
9490: to return anything. This is followed by:
9491:
9492: =item Red CRITICAL: Shutting down
9493:
9494: Just prior to exit.
9495:
9496: =item Free socket: <shutdownretval>
9497:
9498: The HUPSMAN sub was called due to a SIGHUP. all children get killsed, and lond execs itself.
9499: This is followed by:
9500:
9501: =item (Red) CRITICAL: Restarting
9502:
9503: lond is about to exec itself to restart.
9504:
9505: =item (Blue) Updating connections
9506:
9507: (In response to a USR2). All the children (except the one for localhost)
9508: are about to be killed, the hosts tab reread, and Apache reloaded via apachereload.
9509:
9510: =item (Blue) UpdateHosts killing child <pid> for ip <ip>
9511:
9512: Due to USR2 as above.
9513:
9514: =item (Green) keeping child for ip <ip> (pid = <pid>)
9515:
9516: In response to USR2 as above, the child indicated is not being restarted because
9517: it's assumed that we'll always need a child for the localhost.
9518:
9519:
9520: =item Going to check on the children
9521:
9522: Parent is about to check on the health of the child processes.
9523: Note that this is in response to a USR1 sent to the parent lond.
9524: there may be one or more of the next two messages:
9525:
9526: =item <pid> is dead
9527:
9528: A child that we have in our child hash as alive has evidently died.
9529:
9530: =item Child <pid> did not respond
9531:
9532: In the health check the child <pid> did not update/produce a pid_.txt
9533: file when sent it's USR1 signal. That process is killed with a 9 signal, as it's
9534: assumed to be hung in some un-fixable way.
9535:
9536: =item Finished checking children
1.490 droeschl 9537:
1.409 foxr 9538: Master processs's USR1 processing is cojmplete.
9539:
9540: =item (Red) CRITICAL: ------- Starting ------
9541:
9542: (There are more '-'s on either side). Lond has forked itself off to
9543: form a new session and is about to start actual initialization.
9544:
9545: =item (Green) Attempting to start child (<client>)
9546:
9547: Started a new child process for <client>. Client is IO::Socket object
9548: connected to the child. This was as a result of a TCP/IP connection from a client.
9549:
9550: =item Unable to determine who caller was, getpeername returned nothing
1.490 droeschl 9551:
1.409 foxr 9552: In child process initialization. either getpeername returned undef or
9553: a zero sized object was returned. Processing continues, but in my opinion,
9554: this should be cause for the child to exit.
9555:
9556: =item Unable to determine clientip
9557:
9558: In child process initialization. The peer address from getpeername was not defined.
9559: The client address is stored as "Unavailable" and processing continues.
9560:
9561: =item (Yellow) INFO: Connection <ip> <name> connection type = <type>
1.490 droeschl 9562:
1.409 foxr 9563: In child initialization. A good connectionw as received from <ip>.
9564:
9565: =over 2
9566:
9567: =item <name>
9568:
9569: is the name of the client from hosts.tab.
9570:
9571: =item <type>
9572:
9573: Is the connection type which is either
9574:
9575: =over 2
9576:
9577: =item manager
9578:
9579: The connection is from a manager node, not in hosts.tab
9580:
9581: =item client
9582:
9583: the connection is from a non-manager in the hosts.tab
9584:
9585: =item both
9586:
9587: The connection is from a manager in the hosts.tab.
9588:
9589: =back
9590:
9591: =back
9592:
9593: =item (Blue) Certificates not installed -- trying insecure auth
9594:
9595: One of the certificate file, key file or
9596: certificate authority file could not be found for a client attempting
9597: SSL connection intiation. COnnection will be attemptied in in-secure mode.
9598: (this would be a system with an up to date lond that has not gotten a
9599: certificate from us).
9600:
9601: =item (Green) Successful local authentication
9602:
9603: A local connection successfully negotiated the encryption key.
9604: In this case the IDEA key is in a file (that is hopefully well protected).
9605:
9606: =item (Green) Successful ssl authentication with <client>
9607:
9608: The client (<client> is the peer's name in hosts.tab), has successfully
9609: negotiated an SSL connection with this child process.
9610:
9611: =item (Green) Successful insecure authentication with <client>
1.490 droeschl 9612:
1.409 foxr 9613:
9614: The client has successfully negotiated an insecure connection withthe child process.
9615:
9616: =item (Yellow) Attempted insecure connection disallowed
9617:
9618: The client attempted and failed to successfully negotiate a successful insecure
9619: connection. This can happen either because the variable londAllowInsecure is false
9620: or undefined, or becuse the child did not successfully echo back the challenge
9621: string.
9622:
9623:
9624: =back
9625:
1.441 raeburn 9626: =back
9627:
1.409 foxr 9628:
9629: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom