--- loncom/lond 2004/08/18 11:31:50 1.232 +++ loncom/lond 2004/09/14 09:30:07 1.253 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.232 2004/08/18 11:31:50 foxr Exp $ +# $Id: lond,v 1.253 2004/09/14 09:30:07 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -52,12 +52,12 @@ use LONCAPA::lonlocal; use LONCAPA::lonssl; use Fcntl qw(:flock); -my $DEBUG = 1; # Non zero to enable debug log entries. +my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.232 $'; #' stupid emacs +my $VERSION='$Revision: 1.253 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -331,8 +331,43 @@ sub InsecureConnection { } - # +# Safely execute a command (as long as it's not a shel command and doesn +# not require/rely on shell escapes. The function operates by doing a +# a pipe based fork and capturing stdout and stderr from the pipe. +# +# Formal Parameters: +# $line - A line of text to be executed as a command. +# Returns: +# The output from that command. If the output is multiline the caller +# must know how to split up the output. +# +# +sub execute_command { + my ($line) = @_; + my @words = split(/\s/, $line); # Bust the command up into words. + my $output = ""; + + my $pid = open(CHILD, "-|"); + + if($pid) { # Parent process + Debug("In parent process for execute_command"); + my @data = ; # Read the child's outupt... + close CHILD; + foreach my $output_line (@data) { + Debug("Adding $output_line"); + $output .= $output_line; # Presumably has a \n on it. + } + + } else { # Child process + close (STDERR); + open (STDERR, ">&STDOUT");# Combine stderr, and stdout... + exec(@words); # won't return. + } + return $output; +} + + # GetCertificate: Given a transaction that requires a certificate, # this function will extract the certificate from the transaction # request. Note that at this point, the only concept of a certificate @@ -1013,7 +1048,7 @@ sub tie_user_hash { $how, 0640)) { # If this is a namespace for which a history is kept, # make the history log entry: - if (($namespace =~/^nohist\_/) && (defined($loghead))) { + if (($namespace !~/^nohist\_/) && (defined($loghead))) { my $args = scalar @_; Debug(" Opening history: $namespace $args"); my $hfh = IO::File->new(">>$proname/$namespace.hist"); @@ -1282,6 +1317,122 @@ sub push_file_handler { } ®ister_handler("pushfile", \&push_file_handler, 1, 0, 1); +# +# du - list the disk usuage of a directory recursively. +# +# note: stolen code from the ls file handler +# under construction by Rick Banghart +# . +# Parameters: +# $cmd - The command that dispatched us (du). +# $ududir - The directory path to list... I'm not sure what this +# is relative as things like ls:. return e.g. +# no_such_dir. +# $client - Socket open on the client. +# Returns: +# 1 - indicating that the daemon should not disconnect. +# Side Effects: +# The reply is written to $client. +# + +sub du_handler { + my ($cmd, $ududir, $client) = @_; + my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier. + my $userinput = "$cmd:$ududir"; + + if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) { + &Failure($client,"refused\n","$cmd:$ududir"); + return 1; + } + # Since $ududir could have some nasties in it, + # we will require that ududir is a valid + # directory. Just in case someone tries to + # slip us a line like .;(cd /home/httpd rm -rf*) + # etc. + # + if (-d $ududir) { + # And as Shakespeare would say to make + # assurance double sure, + # use execute_command to ensure that the command is not executed in + # a shell that can screw us up. + + my $duout = execute_command("du -ks $ududir"); + $duout=~s/[^\d]//g; #preserve only the numbers + &Reply($client,"$duout\n","$cmd:$ududir"); + } else { + + &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); + + } + return 1; +} +®ister_handler("du", \&du_handler, 0, 1, 0); + + +# +# ls - list the contents of a directory. For each file in the +# selected directory the filename followed by the full output of +# the stat function is returned. The returned info for each +# file are separated by ':'. The stat fields are separated by &'s. +# Parameters: +# $cmd - The command that dispatched us (ls). +# $ulsdir - The directory path to list... I'm not sure what this +# is relative as things like ls:. return e.g. +# no_such_dir. +# $client - Socket open on the client. +# Returns: +# 1 - indicating that the daemon should not disconnect. +# Side Effects: +# The reply is written to $client. +# +sub ls_handler { + my ($cmd, $ulsdir, $client) = @_; + + my $userinput = "$cmd:$ulsdir"; + + my $obs; + my $rights; + my $ulsout=''; + my $ulsfn; + if (-e $ulsdir) { + if(-d $ulsdir) { + if (opendir(LSDIR,$ulsdir)) { + while ($ulsfn=readdir(LSDIR)) { + undef $obs, $rights; + my @ulsstats=stat($ulsdir.'/'.$ulsfn); + #We do some obsolete checking here + if(-e $ulsdir.'/'.$ulsfn.".meta") { + open(FILE, $ulsdir.'/'.$ulsfn.".meta"); + my @obsolete=; + foreach my $obsolete (@obsolete) { + if($obsolete =~ m|()(on)|) { $obs = 1; } + if($obsolete =~ m|()(default)|) { $rights = 1; } + } + } + $ulsout.=$ulsfn.'&'.join('&',@ulsstats); + if($obs eq '1') { $ulsout.="&1"; } + else { $ulsout.="&0"; } + if($rights eq '1') { $ulsout.="&1:"; } + else { $ulsout.="&0:"; } + } + closedir(LSDIR); + } + } else { + my @ulsstats=stat($ulsdir); + $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; + } + } else { + $ulsout='no_such_dir'; + } + if ($ulsout eq '') { $ulsout='empty'; } + &Reply($client, "$ulsout\n", $userinput); # This supports debug logging. + + return 1; + +} +®ister_handler("ls", \&ls_handler, 0, 1, 0); + + # Process a reinit request. Reinit requests that either @@ -1616,7 +1767,7 @@ sub change_authentication_handler { my $result=&make_passwd_file($uname, $umode,$npass,$passfilename); &Reply($client, $result, $userinput); } else { - &Failure($client, "non_authorized", $userinput); # Fail the user now. + &Failure($client, "non_authorized\n", $userinput); # Fail the user now. } } return 1; @@ -1843,8 +1994,19 @@ sub remove_user_file_handler { if (-e $udir) { my $file=$udir.'/userfiles/'.$ufile; if (-e $file) { - unlink($file); + # + # If the file is a regular file unlink is fine... + # However it's possible the client wants a dir. + # removed, in which case rmdir is more approprate: + # + if (-f $file){ + unlink($file); + } elsif(-d $file) { + rmdir($file); + } if (-e $file) { + # File is still there after we deleted it ?!? + &Failure($client, "failed\n", "$cmd:$tail"); } else { &Reply($client, "ok\n", "$cmd:$tail"); @@ -1860,6 +2022,91 @@ sub remove_user_file_handler { } ®ister_handler("removeuserfile", \&remove_user_file_handler, 0,1,0); +# +# make a directory in a user's home directory userfiles subdirectory. +# Parameters: +# cmd - the Lond request keyword that got us here. +# tail - the part of the command past the keyword. +# client- File descriptor connected with the client. +# +# Returns: +# 1 - Continue processing. + +sub mkdir_user_file_handler { + my ($cmd, $tail, $client) = @_; + + my ($dir) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent. + $dir=&unescape($dir); + my ($udom,$uname,$ufile) = ($dir =~ m|^([^/]+)/([^/]+)/(.+)$|); + if ($ufile =~m|/\.\./|) { + # any files paths with /../ in them refuse + # to deal with + &Failure($client, "refused\n", "$cmd:$tail"); + } else { + my $udir = &propath($udom,$uname); + if (-e $udir) { + my $newdir=$udir.'/userfiles/'.$ufile; + if (!-e $newdir) { + mkdir($newdir); + if (!-e $newdir) { + &Failure($client, "failed\n", "$cmd:$tail"); + } else { + &Reply($client, "ok\n", "$cmd:$tail"); + } + } else { + &Failure($client, "not_found\n", "$cmd:$tail"); + } + } else { + &Failure($client, "not_home\n", "$cmd:$tail"); + } + } + return 1; +} +®ister_handler("mkdiruserfile", \&mkdir_user_file_handler, 0,1,0); + +# +# rename a file in a user's home directory userfiles subdirectory. +# Parameters: +# cmd - the Lond request keyword that got us here. +# tail - the part of the command past the keyword. +# client- File descriptor connected with the client. +# +# Returns: +# 1 - Continue processing. + +sub rename_user_file_handler { + my ($cmd, $tail, $client) = @_; + + my ($udom,$uname,$old,$new) = split(/:/, $tail); + $old=&unescape($old); + $new=&unescape($new); + if ($new =~m|/\.\./| || $old =~m|/\.\./|) { + # any files paths with /../ in them refuse to deal with + &Failure($client, "refused\n", "$cmd:$tail"); + } else { + my $udir = &propath($udom,$uname); + if (-e $udir) { + my $oldfile=$udir.'/userfiles/'.$old; + my $newfile=$udir.'/userfiles/'.$new; + if (-e $newfile) { + &Failure($client, "exists\n", "$cmd:$tail"); + } elsif (! -e $oldfile) { + &Failure($client, "not_found\n", "$cmd:$tail"); + } else { + if (!rename($oldfile,$newfile)) { + &Failure($client, "failed\n", "$cmd:$tail"); + } else { + &Reply($client, "ok\n", "$cmd:$tail"); + } + } + } else { + &Failure($client, "not_home\n", "$cmd:$tail"); + } + } + return 1; +} +®ister_handler("renameuserfile", \&rename_user_file_handler, 0,1,0); + # # Authenticate access to a user file by checking the user's @@ -1878,14 +2125,14 @@ sub token_auth_user_file_handler { my ($fname, $session) = split(/:/, $tail); chomp($session); - my $reply='non_auth'; + my $reply="non_auth\n"; if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. $session.'.id')) { while (my $line=) { - if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; } + if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; } } close(ENVIN); - &Reply($client, $reply); + &Reply($client, $reply, "$cmd:$tail"); } else { &Failure($client, "invalid_token\n", "$cmd:$tail"); } @@ -2023,7 +2270,7 @@ sub put_user_profile_entry { my $userinput = "$cmd:$tail"; - my ($udom,$uname,$namespace,$what) =split(/:/,$tail); + my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4); if ($namespace ne 'roles') { chomp($what); my $hashref = &tie_user_hash($udom, $uname, $namespace, @@ -2696,6 +2943,864 @@ sub restore_handler { } ®ister_handler("restore", \&restore_handler, 0,1,0); + +# +# Add a chat message to to a discussion board. +# +# Parameters: +# $cmd - Request keyword. +# $tail - Tail of the command. A colon separated list +# containing: +# cdom - Domain on which the chat board lives +# cnum - Identifier of the discussion group. +# post - Body of the posting. +# $client - Socket open on the client. +# Returns: +# 1 - Indicating caller should keep on processing. +# +# Side-effects: +# writes a reply to the client. +# +# +sub send_chat_handler { + my ($cmd, $tail, $client) = @_; + + + my $userinput = "$cmd:$tail"; + + my ($cdom,$cnum,$newpost)=split(/\:/,$tail); + &chat_add($cdom,$cnum,$newpost); + &Reply($client, "ok\n", $userinput); + + return 1; +} +®ister_handler("chatsend", \&send_chat_handler, 0, 1, 0); +# +# Retrieve the set of chat messagss from a discussion board. +# +# Parameters: +# $cmd - Command keyword that initiated the request. +# $tail - Remainder of the request after the command +# keyword. In this case a colon separated list of +# chat domain - Which discussion board. +# chat id - Discussion thread(?) +# domain/user - Authentication domain and username +# of the requesting person. +# $client - Socket open on the client program. +# Returns: +# 1 - continue processing +# Side effects: +# Response is written to the client. +# +sub retrieve_chat_handler { + my ($cmd, $tail, $client) = @_; + + + my $userinput = "$cmd:$tail"; + + my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail); + my $reply=''; + foreach (&get_chat($cdom,$cnum,$udom,$uname)) { + $reply.=&escape($_).':'; + } + $reply=~s/\:$//; + &Reply($client, $reply."\n", $userinput); + + + return 1; +} +®ister_handler("chatretr", \&retrieve_chat_handler, 0, 1, 0); + +# +# Initiate a query of an sql database. SQL query repsonses get put in +# a file for later retrieval. This prevents sql query results from +# bottlenecking the system. Note that with loncnew, perhaps this is +# less of an issue since multiple outstanding requests can be concurrently +# serviced. +# +# Parameters: +# $cmd - COmmand keyword that initiated the request. +# $tail - Remainder of the command after the keyword. +# For this function, this consists of a query and +# 3 arguments that are self-documentingly labelled +# in the original arg1, arg2, arg3. +# $client - Socket open on the client. +# Return: +# 1 - Indicating processing should continue. +# Side-effects: +# a reply is written to $client. +# +sub send_query_handler { + my ($cmd, $tail, $client) = @_; + + + my $userinput = "$cmd:$tail"; + + my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail); + $query=~s/\n*$//g; + &Reply($client, "". &sql_reply("$clientname\&$query". + "\&$arg1"."\&$arg2"."\&$arg3")."\n", + $userinput); + + return 1; +} +®ister_handler("querysend", \&send_query_handler, 0, 1, 0); + +# +# Add a reply to an sql query. SQL queries are done asyncrhonously. +# The query is submitted via a "querysend" transaction. +# There it is passed on to the lonsql daemon, queued and issued to +# mysql. +# This transaction is invoked when the sql transaction is complete +# it stores the query results in flie and indicates query completion. +# presumably local software then fetches this response... I'm guessing +# the sequence is: lonc does a querysend, we ask lonsql to do it. +# lonsql on completion of the query interacts with the lond of our +# client to do a query reply storing two files: +# - id - The results of the query. +# - id.end - Indicating the transaction completed. +# NOTE: id is a unique id assigned to the query and querysend time. +# Parameters: +# $cmd - Command keyword that initiated this request. +# $tail - Remainder of the tail. In this case that's a colon +# separated list containing the query Id and the +# results of the query. +# $client - Socket open on the client. +# Return: +# 1 - Indicating that we should continue processing. +# Side effects: +# ok written to the client. +# +sub reply_query_handler { + my ($cmd, $tail, $client) = @_; + + + my $userinput = "$cmd:$tail"; + + my ($cmd,$id,$reply)=split(/:/,$userinput); + my $store; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new(">$execdir/tmp/$id")) { + $reply=~s/\&/\n/g; + print $store $reply; + close $store; + my $store2=IO::File->new(">$execdir/tmp/$id.end"); + print $store2 "done\n"; + close $store2; + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0) + ." IO::File->new Failed ". + "while attempting queryreply\n", $userinput); + } + + + return 1; +} +®ister_handler("queryreply", \&reply_query_handler, 0, 1, 0); + +# +# Process the courseidput request. Not quite sure what this means +# at the system level sense. It appears a gdbm file in the +# /home/httpd/lonUsers/$domain/nohist_courseids is tied and +# a set of entries made in that database. +# +# Parameters: +# $cmd - The command keyword that initiated this request. +# $tail - Tail of the command. In this case consists of a colon +# separated list contaning the domain to apply this to and +# an ampersand separated list of keyword=value pairs. +# $client - Socket open on the client. +# Returns: +# 1 - indicating that processing should continue +# +# Side effects: +# reply is written to the client. +# +sub put_course_id_handler { + my ($cmd, $tail, $client) = @_; + + + my $userinput = "$cmd:$tail"; + + my ($udom, $what) = split(/:/, $tail); + chomp($what); + my $now=time; + my @pairs=split(/\&/,$what); + + my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); + if ($hashref) { + foreach my $pair (@pairs) { + my ($key,$descr,$inst_code)=split(/=/,$pair); + $hashref->{$key}=$descr.':'.$inst_code.':'.$now; + } + if (untie(%$hashref)) { + &Reply( $client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting courseidput\n", $userinput); + } + } else { + &Failure($client, "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting courseidput\n", $userinput); + } + + + return 1; +} +®ister_handler("courseidput", \&put_course_id_handler, 0, 1, 0); + +# Retrieves the value of a course id resource keyword pattern +# defined since a starting date. Both the starting date and the +# keyword pattern are optional. If the starting date is not supplied it +# is treated as the beginning of time. If the pattern is not found, +# it is treatred as "." matching everything. +# +# Parameters: +# $cmd - Command keyword that resulted in us being dispatched. +# $tail - The remainder of the command that, in this case, consists +# of a colon separated list of: +# domain - The domain in which the course database is +# defined. +# since - Optional parameter describing the minimum +# time of definition(?) of the resources that +# will match the dump. +# description - regular expression that is used to filter +# the dump. Only keywords matching this regexp +# will be used. +# $client - The socket open on the client. +# Returns: +# 1 - Continue processing. +# Side Effects: +# a reply is written to $client. +sub dump_course_id_handler { + my ($cmd, $tail, $client) = @_; + + my $userinput = "$cmd:$tail"; + + my ($udom,$since,$description) =split(/:/,$tail); + if (defined($description)) { + $description=&unescape($description); + } else { + $description='.'; + } + unless (defined($since)) { $since=0; } + my $qresult=''; + my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT()); + if ($hashref) { + while (my ($key,$value) = each(%$hashref)) { + my ($descr,$lasttime,$inst_code); + if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { + ($descr,$inst_code,$lasttime)=($1,$2,$3); + } else { + ($descr,$lasttime) = split(/\:/,$value); + } + if ($lasttime<$since) { next; } + if ($description eq '.') { + $qresult.=$key.'='.$descr.':'.$inst_code.'&'; + } else { + my $unescapeVal = &unescape($descr); + if (eval('$unescapeVal=~/\Q$description\E/i')) { + $qresult.=$key.'='.$descr.':'.$inst_code.'&'; + } + } + } + if (untie(%$hashref)) { + chop($qresult); + &Reply($client, "$qresult\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting courseiddump\n", $userinput); + } + } else { + &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting courseiddump\n", $userinput); + } + + + return 1; +} +®ister_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0); + +# +# Puts an id to a domains id database. +# +# Parameters: +# $cmd - The command that triggered us. +# $tail - Remainder of the request other than the command. This is a +# colon separated list containing: +# $domain - The domain for which we are writing the id. +# $pairs - The id info to write... this is and & separated list +# of keyword=value. +# $client - Socket open on the client. +# Returns: +# 1 - Continue processing. +# Side effects: +# reply is written to $client. +# +sub put_id_handler { + my ($cmd,$tail,$client) = @_; + + + my $userinput = "$cmd:$tail"; + + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my @pairs=split(/\&/,$what); + my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(), + "P", $what); + if ($hashref) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + $hashref->{$key}=$value; + } + if (untie(%$hashref)) { + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting idput\n", $userinput); + } + } else { + &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting idput\n", $userinput); + } + + return 1; +} + +®ister_handler("idput", \&put_id_handler, 0, 1, 0); +# +# Retrieves a set of id values from the id database. +# Returns an & separated list of results, one for each requested id to the +# client. +# +# Parameters: +# $cmd - Command keyword that caused us to be dispatched. +# $tail - Tail of the command. Consists of a colon separated: +# domain - the domain whose id table we dump +# ids Consists of an & separated list of +# id keywords whose values will be fetched. +# nonexisting keywords will have an empty value. +# $client - Socket open on the client. +# +# Returns: +# 1 - indicating processing should continue. +# Side effects: +# An & separated list of results is written to $client. +# +sub get_id_handler { + my ($cmd, $tail, $client) = @_; + + + my $userinput = "$client:$tail"; + + my ($udom,$what)=split(/:/,$tail); + chomp($what); + my @queries=split(/\&/,$what); + my $qresult=''; + my $hashref = &tie_domain_hash($udom, "ids", &GDBM_READER()); + if ($hashref) { + for (my $i=0;$i<=$#queries;$i++) { + $qresult.="$hashref->{$queries[$i]}&"; + } + if (untie(%$hashref)) { + $qresult=~s/\&$//; + &Reply($client, "$qresult\n", $userinput); + } else { + &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". + "while attempting idget\n",$userinput); + } + } else { + &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". + "while attempting idget\n",$userinput); + } + + return 1; +} + +register_handler("idget", \&get_id_handler, 0, 1, 0); + +# +# Process the tmpput command I'm not sure what this does.. Seems to +# create a file in the lonDaemons/tmp directory of the form $id.tmp +# where Id is the client's ip concatenated with a sequence number. +# The file will contain some value that is passed in. Is this e.g. +# a login token? +# +# Parameters: +# $cmd - The command that got us dispatched. +# $tail - The remainder of the request following $cmd: +# In this case this will be the contents of the file. +# $client - Socket connected to the client. +# Returns: +# 1 indicating processing can continue. +# Side effects: +# A file is created in the local filesystem. +# A reply is sent to the client. +sub tmp_put_handler { + my ($cmd, $what, $client) = @_; + + my $userinput = "$cmd:$what"; # Reconstruct for logging. + + + my $store; + $tmpsnum++; + my $id=$$.'_'.$clientip.'_'.$tmpsnum; + $id=~s/\W/\_/g; + $what=~s/\n//g; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { + print $store $what; + close $store; + &Reply($client, "$id\n", $userinput); + } else { + &Failure( $client, "error: ".($!+0)."IO::File->new Failed ". + "while attempting tmpput\n", $userinput); + } + return 1; + +} +®ister_handler("tmpput", \&tmp_put_handler, 0, 1, 0); +# Processes the tmpget command. This command returns the contents +# of a temporary resource file(?) created via tmpput. +# +# Paramters: +# $cmd - Command that got us dispatched. +# $id - Tail of the command, contain the id of the resource +# we want to fetch. +# $client - socket open on the client. +# Return: +# 1 - Inidcating processing can continue. +# Side effects: +# A reply is sent to the client. + +# +sub tmp_get_handler { + my ($cmd, $id, $client) = @_; + + my $userinput = "$cmd:$id"; + + + $id=~s/\W/\_/g; + my $store; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { + my $reply=<$store>; + &Reply( $client, "$reply\n", $userinput); + close $store; + } else { + &Failure( $client, "error: ".($!+0)."IO::File->new Failed ". + "while attempting tmpget\n", $userinput); + } + + return 1; +} +®ister_handler("tmpget", \&tmp_get_handler, 0, 1, 0); +# +# Process the tmpdel command. This command deletes a temp resource +# created by the tmpput command. +# +# Parameters: +# $cmd - Command that got us here. +# $id - Id of the temporary resource created. +# $client - socket open on the client process. +# +# Returns: +# 1 - Indicating processing should continue. +# Side Effects: +# A file is deleted +# A reply is sent to the client. +sub tmp_del_handler { + my ($cmd, $id, $client) = @_; + + my $userinput= "$cmd:$id"; + + chomp($id); + $id=~s/\W/\_/g; + my $execdir=$perlvar{'lonDaemons'}; + if (unlink("$execdir/tmp/$id.tmp")) { + &Reply($client, "ok\n", $userinput); + } else { + &Failure( $client, "error: ".($!+0)."Unlink tmp Failed ". + "while attempting tmpdel\n", $userinput); + } + + return 1; + +} +®ister_handler("tmpdel", \&tmp_del_handler, 0, 1, 0); +# +# Processes the setannounce command. This command +# creates a file named announce.txt in the top directory of +# the documentn root and sets its contents. The announce.txt file is +# printed in its entirety at the LonCAPA login page. Note: +# once the announcement.txt fileis created it cannot be deleted. +# However, setting the contents of the file to empty removes the +# announcement from the login page of loncapa so who cares. +# +# Parameters: +# $cmd - The command that got us dispatched. +# $announcement - The text of the announcement. +# $client - Socket open on the client process. +# Retunrns: +# 1 - Indicating request processing should continue +# Side Effects: +# The file {DocRoot}/announcement.txt is created. +# A reply is sent to $client. +# +sub set_announce_handler { + my ($cmd, $announcement, $client) = @_; + + my $userinput = "$cmd:$announcement"; + + chomp($announcement); + $announcement=&unescape($announcement); + if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. + '/announcement.txt')) { + print $store $announcement; + close $store; + &Reply($client, "ok\n", $userinput); + } else { + &Failure($client, "error: ".($!+0)."\n", $userinput); + } + + return 1; +} +®ister_handler("setannounce", \&set_announce_handler, 0, 1, 0); +# +# Return the version of the daemon. This can be used to determine +# the compatibility of cross version installations or, alternatively to +# simply know who's out of date and who isn't. Note that the version +# is returned concatenated with the tail. +# Parameters: +# $cmd - the request that dispatched to us. +# $tail - Tail of the request (client's version?). +# $client - Socket open on the client. +#Returns: +# 1 - continue processing requests. +# Side Effects: +# Replies with version to $client. +sub get_version_handler { + my ($cmd, $tail, $client) = @_; + + my $userinput = $cmd.$tail; + + &Reply($client, &version($userinput)."\n", $userinput); + + + return 1; +} +®ister_handler("version", \&get_version_handler, 0, 1, 0); +# Set the current host and domain. This is used to support +# multihomed systems. Each IP of the system, or even separate daemons +# on the same IP can be treated as handling a separate lonCAPA virtual +# machine. This command selects the virtual lonCAPA. The client always +# knows the right one since it is lonc and it is selecting the domain/system +# from the hosts.tab file. +# Parameters: +# $cmd - Command that dispatched us. +# $tail - Tail of the command (domain/host requested). +# $socket - Socket open on the client. +# +# Returns: +# 1 - Indicates the program should continue to process requests. +# Side-effects: +# The default domain/system context is modified for this daemon. +# a reply is sent to the client. +# +sub set_virtual_host_handler { + my ($cmd, $tail, $socket) = @_; + + my $userinput ="$cmd:$tail"; + + &Reply($client, &sethost($userinput)."\n", $userinput); + + + return 1; +} +®ister_handler("sethost", \&set_virtual_host_handler, 0, 1, 0); + +# Process a request to exit: +# - "bye" is sent to the client. +# - The client socket is shutdown and closed. +# - We indicate to the caller that we should exit. +# Formal Parameters: +# $cmd - The command that got us here. +# $tail - Tail of the command (empty). +# $client - Socket open on the tail. +# Returns: +# 0 - Indicating the program should exit!! +# +sub exit_handler { + my ($cmd, $tail, $client) = @_; + + my $userinput = "$cmd:$tail"; + + &logthis("Client $clientip ($clientname) hanging up: $userinput"); + &Reply($client, "bye\n", $userinput); + $client->shutdown(2); # shutdown the socket forcibly. + $client->close(); + + return 0; +} +®ister_handler("exit", \&exit_handler, 0,1,1); +®ister_handler("init", \&exit_handler, 0,1,1); +®ister_handler("quit", \&exit_handler, 0,1,1); + +# Determine if auto-enrollment is enabled. +# Note that the original had what I believe to be a defect. +# The original returned 0 if the requestor was not a registerd client. +# It should return "refused". +# Formal Parameters: +# $cmd - The command that invoked us. +# $tail - The tail of the command (Extra command parameters. +# $client - The socket open on the client that issued the request. +# Returns: +# 1 - Indicating processing should continue. +# +sub enrollment_enabled_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = $cmd.":".$tail; # For logging purposes. + + + my $cdom = split(/:/, $tail); # Domain we're asking about. + my $outcome = &localenroll::run($cdom); + &Reply($client, "$outcome\n", $userinput); + + return 1; +} +®ister_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0); + +# Get the official sections for which auto-enrollment is possible. +# Since the admin people won't know about 'unofficial sections' +# we cannot auto-enroll on them. +# Formal Parameters: +# $cmd - The command request that got us dispatched here. +# $tail - The remainder of the request. In our case this +# will be split into: +# $coursecode - The course name from the admin point of view. +# $cdom - The course's domain(?). +# $client - Socket open on the client. +# Returns: +# 1 - Indiciting processing should continue. +# +sub get_sections_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + + my ($coursecode, $cdom) = split(/:/, $tail); + my @secs = &localenroll::get_sections($coursecode,$cdom); + my $seclist = &escape(join(':',@secs)); + + &Reply($client, "$seclist\n", $userinput); + + + return 1; +} +®ister_handler("autogetsections", \&get_sections_handler, 0, 1, 0); + +# Validate the owner of a new course section. +# +# Formal Parameters: +# $cmd - Command that got us dispatched. +# $tail - the remainder of the command. For us this consists of a +# colon separated string containing: +# $inst - Course Id from the institutions point of view. +# $owner - Proposed owner of the course. +# $cdom - Domain of the course (from the institutions +# point of view?).. +# $client - Socket open on the client. +# +# Returns: +# 1 - Processing should continue. +# +sub validate_course_owner_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my ($inst_course_id, $owner, $cdom) = split(/:/, $tail); + + my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom); + &Reply($client, "$outcome\n", $userinput); + + + + return 1; +} +®ister_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0); +# +# Validate a course section in the official schedule of classes +# from the institutions point of view (part of autoenrollment). +# +# Formal Parameters: +# $cmd - The command request that got us dispatched. +# $tail - The tail of the command. In this case, +# this is a colon separated set of words that will be split +# into: +# $inst_course_id - The course/section id from the +# institutions point of view. +# $cdom - The domain from the institutions +# point of view. +# $client - Socket open on the client. +# Returns: +# 1 - Indicating processing should continue. +# +sub validate_course_section_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + my ($inst_course_id, $cdom) = split(/:/, $tail); + + my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom); + &Reply($client, "$outcome\n", $userinput); + + + return 1; +} +®ister_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0); + +# +# Create a password for a new auto-enrollment user. +# I think/guess, this password allows access to the institutions +# AIS class list server/services. Stuart can correct this comment +# when he finds out how wrong I am. +# +# Formal Parameters: +# $cmd - The command request that got us dispatched. +# $tail - The tail of the command. In this case this is a colon separated +# set of words that will be split into: +# $authparam - An authentication parameter (username??). +# $cdom - The domain of the course from the institution's +# point of view. +# $client - The socket open on the client. +# Returns: +# 1 - continue processing. +# +sub create_auto_enroll_password_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + + my ($authparam, $cdom) = split(/:/, $userinput); + + my ($create_passwd,$authchk); + ($authparam, + $create_passwd, + $authchk) = &localenroll::create_password($authparam,$cdom); + + &Reply($client, &escape($authparam.':'.$create_passwd.':'.$authchk)."\n", + $userinput); + + + return 1; +} +®ister_handler("autocreatepassword", \&create_auto_enroll_password_handler, + 0, 1, 0); + +# Retrieve and remove temporary files created by/during autoenrollment. +# +# Formal Parameters: +# $cmd - The command that got us dispatched. +# $tail - The tail of the command. In our case this is a colon +# separated list that will be split into: +# $filename - The name of the file to remove. +# The filename is given as a path relative to +# the LonCAPA temp file directory. +# $client - Socket open on the client. +# +# Returns: +# 1 - Continue processing. + +sub retrieve_auto_file_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "cmd:$tail"; + + my ($filename) = split(/:/, $tail); + + my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename; + if ( (-e $source) && ($filename ne '') ) { + my $reply = ''; + if (open(my $fh,$source)) { + while (<$fh>) { + chomp($_); + $_ =~ s/^\s+//g; + $_ =~ s/\s+$//g; + $reply .= $_; + } + close($fh); + &Reply($client, &escape($reply)."\n", $userinput); + +# Does this have to be uncommented??!? (RF). +# +# unlink($source); + } else { + &Failure($client, "error\n", $userinput); + } + } else { + &Failure($client, "error\n", $userinput); + } + + + return 1; +} +®ister_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0); + +# +# Read and retrieve institutional code format (for support form). +# Formal Parameters: +# $cmd - Command that dispatched us. +# $tail - Tail of the command. In this case it conatins +# the course domain and the coursename. +# $client - Socket open on the client. +# Returns: +# 1 - Continue processing. +# +sub get_institutional_code_format_handler { + my ($cmd, $tail, $client) = @_; + my $userinput = "$cmd:$tail"; + + my $reply; + my($cdom,$course) = split(/:/,$tail); + my @pairs = split/\&/,$course; + my %instcodes = (); + my %codes = (); + my @codetitles = (); + my %cat_titles = (); + my %cat_order = (); + foreach (@pairs) { + my ($key,$value) = split/=/,$_; + $instcodes{&unescape($key)} = &unescape($value); + } + my $formatreply = &localenroll::instcode_format($cdom, + \%instcodes, + \%codes, + \@codetitles, + \%cat_titles, + \%cat_order); + if ($formatreply eq 'ok') { + my $codes_str = &hash2str(%codes); + my $codetitles_str = &array2str(@codetitles); + my $cat_titles_str = &hash2str(%cat_titles); + my $cat_order_str = &hash2str(%cat_order); + &Reply($client, + $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':' + .$cat_order_str."\n", + $userinput); + } else { + # this else branch added by RF since if not ok, lonc will + # hang waiting on reply until timeout. + # + &Reply($client, "format_error\n", $userinput); + } + + return 1; +} + +®ister_handler("autoinstcodeformat", \&get_institutional_code_format_handler, + 0,1,0); + +# +# +# # # #--------------------------------------------------------------- @@ -2713,7 +3818,7 @@ sub get_request { my $input = <$client>; chomp($input); - Debug("get_request: Request = $input\n"); + &Debug("get_request: Request = $input\n"); &status('Processing '.$clientname.':'.$input); @@ -2739,7 +3844,7 @@ sub process_request { $userinput = decipher($userinput); $wasenc=1; if(!$userinput) { # Cipher not defined. - &Failure($client, "error: Encrypted data without negotated key"); + &Failure($client, "error: Encrypted data without negotated key\n"); return 0; } } @@ -2811,390 +3916,8 @@ sub process_request { #------------------- Commands not yet in spearate handlers. -------------- - - -# -------------------------------------------------------------------- chatsend - if ($userinput =~ /^chatsend/) { - if(isClient) { - my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); - &chatadd($cdom,$cnum,$newpost); - print $client "ok\n"; - } else { - Reply($client, "refused\n", $userinput); - - } -# -------------------------------------------------------------------- chatretr - } elsif ($userinput =~ /^chatretr/) { - if(isClient) { - my - ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); - my $reply=''; - foreach (&getchat($cdom,$cnum,$udom,$uname)) { - $reply.=&escape($_).':'; - } - $reply=~s/\:$//; - print $client $reply."\n"; - } else { - Reply($client, "refused\n", $userinput); - - } -# ------------------------------------------------------------------- querysend - } elsif ($userinput =~ /^querysend/) { - if (isClient) { - my ($cmd,$query, - $arg1,$arg2,$arg3)=split(/\:/,$userinput); - $query=~s/\n*$//g; - print $client "". - sqlreply("$clientname\&$query". - "\&$arg1"."\&$arg2"."\&$arg3")."\n"; - } else { - Reply($client, "refused\n", $userinput); - - } -# ------------------------------------------------------------------ queryreply - } elsif ($userinput =~ /^queryreply/) { - if(isClient) { - my ($cmd,$id,$reply)=split(/:/,$userinput); - my $store; - my $execdir=$perlvar{'lonDaemons'}; - if ($store=IO::File->new(">$execdir/tmp/$id")) { - $reply=~s/\&/\n/g; - print $store $reply; - close $store; - my $store2=IO::File->new(">$execdir/tmp/$id.end"); - print $store2 "done\n"; - close $store2; - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." IO::File->new Failed ". - "while attempting queryreply\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } -# ----------------------------------------------------------------- courseidput - } elsif ($userinput =~ /^courseidput/) { - if(isClient) { - my ($cmd,$udom,$what)=split(/:/,$userinput); - chomp($what); - $udom=~s/\W//g; - my $proname= - "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; - my $now=time; - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { - foreach my $pair (@pairs) { - my ($key,$descr,$inst_code)=split(/=/,$pair); - $hash{$key}=$descr.':'.$inst_code.':'.$now; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting courseidput\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting courseidput\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } -# ---------------------------------------------------------------- courseiddump - } elsif ($userinput =~ /^courseiddump/) { - if(isClient) { - my ($cmd,$udom,$since,$description) - =split(/:/,$userinput); - if (defined($description)) { - $description=&unescape($description); - } else { - $description='.'; - } - unless (defined($since)) { $since=0; } - my $qresult=''; - my $proname= - "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { - while (my ($key,$value) = each(%hash)) { - my ($descr,$lasttime,$inst_code); - if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { - ($descr,$inst_code,$lasttime)=($1,$2,$3); - } else { - ($descr,$lasttime) = split(/\:/,$value); - } - if ($lasttime<$since) { next; } - if ($description eq '.') { - $qresult.=$key.'='.$descr.':'.$inst_code.'&'; - } else { - my $unescapeVal = &unescape($descr); - if (eval('$unescapeVal=~/\Q$description\E/i')) { - $qresult.=$key.'='.$descr.':'.$inst_code.'&'; - } - } - } - if (untie(%hash)) { - chop($qresult); - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting courseiddump\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting courseiddump\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } -# ----------------------------------------------------------------------- idput - } elsif ($userinput =~ /^idput/) { - if(isClient) { - my ($cmd,$udom,$what)=split(/:/,$userinput); - chomp($what); - $udom=~s/\W//g; - my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; - my $now=time; - my @pairs=split(/\&/,$what); - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { - { - my $hfh; - if ($hfh=IO::File->new(">>$proname.hist")) { - print $hfh "P:$now:$what\n"; - } - } - foreach my $pair (@pairs) { - my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value; - } - if (untie(%hash)) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting idput\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting idput\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } -# ----------------------------------------------------------------------- idget - } elsif ($userinput =~ /^idget/) { - if(isClient) { - my ($cmd,$udom,$what)=split(/:/,$userinput); - chomp($what); - $udom=~s/\W//g; - my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; - my @queries=split(/\&/,$what); - my $qresult=''; - my %hash; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { - for (my $i=0;$i<=$#queries;$i++) { - $qresult.="$hash{$queries[$i]}&"; - } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; - } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting idget\n"; - } - } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting idget\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } -# ---------------------------------------------------------------------- tmpput - } elsif ($userinput =~ /^tmpput/) { - if(isClient) { - my ($cmd,$what)=split(/:/,$userinput); - my $store; - $tmpsnum++; - my $id=$$.'_'.$clientip.'_'.$tmpsnum; - $id=~s/\W/\_/g; - $what=~s/\n//g; - my $execdir=$perlvar{'lonDaemons'}; - if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { - print $store $what; - close $store; - print $client "$id\n"; - } - else { - print $client "error: ".($!+0) - ."IO::File->new Failed ". - "while attempting tmpput\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } - -# ---------------------------------------------------------------------- tmpget - } elsif ($userinput =~ /^tmpget/) { - if(isClient) { - my ($cmd,$id)=split(/:/,$userinput); - chomp($id); - $id=~s/\W/\_/g; - my $store; - my $execdir=$perlvar{'lonDaemons'}; - if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { - my $reply=<$store>; - print $client "$reply\n"; - close $store; - } - else { - print $client "error: ".($!+0) - ."IO::File->new Failed ". - "while attempting tmpget\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } -# ---------------------------------------------------------------------- tmpdel - } elsif ($userinput =~ /^tmpdel/) { - if(isClient) { - my ($cmd,$id)=split(/:/,$userinput); - chomp($id); - $id=~s/\W/\_/g; - my $execdir=$perlvar{'lonDaemons'}; - if (unlink("$execdir/tmp/$id.tmp")) { - print $client "ok\n"; - } else { - print $client "error: ".($!+0) - ."Unlink tmp Failed ". - "while attempting tmpdel\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } -# ----------------------------------------- portfolio directory list (portls) - } elsif ($userinput =~ /^portls/) { - if(isClient) { - my ($cmd,$uname,$udom)=split(/:/,$userinput); - my $udir=propath($udom,$uname).'/userfiles/portfolio'; - my $dirLine=''; - my $dirContents=''; - if (opendir(LSDIR,$udir.'/')){ - while ($dirLine = readdir(LSDIR)){ - $dirContents = $dirContents.$dirLine.'
'; - } - } else { - $dirContents = "No directory found\n"; - } - print $client $dirContents."\n"; - } else { - Reply($client, "refused\n", $userinput); - } -# -------------------------------------------------------------------------- ls - } elsif ($userinput =~ /^ls/) { - if(isClient) { - my $obs; - my $rights; - my ($cmd,$ulsdir)=split(/:/,$userinput); - my $ulsout=''; - my $ulsfn; - if (-e $ulsdir) { - if(-d $ulsdir) { - if (opendir(LSDIR,$ulsdir)) { - while ($ulsfn=readdir(LSDIR)) { - undef $obs, $rights; - my @ulsstats=stat($ulsdir.'/'.$ulsfn); - #We do some obsolete checking here - if(-e $ulsdir.'/'.$ulsfn.".meta") { - open(FILE, $ulsdir.'/'.$ulsfn.".meta"); - my @obsolete=; - foreach my $obsolete (@obsolete) { - if($obsolete =~ m|()(on)|) { $obs = 1; } - if($obsolete =~ m|()(default)|) { $rights = 1; } - } - } - $ulsout.=$ulsfn.'&'.join('&',@ulsstats); - if($obs eq '1') { $ulsout.="&1"; } - else { $ulsout.="&0"; } - if($rights eq '1') { $ulsout.="&1:"; } - else { $ulsout.="&0:"; } - } - closedir(LSDIR); - } - } else { - my @ulsstats=stat($ulsdir); - $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; - } - } else { - $ulsout='no_such_dir'; - } - if ($ulsout eq '') { $ulsout='empty'; } - print $client "$ulsout\n"; - } else { - Reply($client, "refused\n", $userinput); - - } -# ----------------------------------------------------------------- setannounce - } elsif ($userinput =~ /^setannounce/) { - if (isClient) { - my ($cmd,$announcement)=split(/:/,$userinput); - chomp($announcement); - $announcement=&unescape($announcement); - if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. - '/announcement.txt')) { - print $store $announcement; - close $store; - print $client "ok\n"; - } else { - print $client "error: ".($!+0)."\n"; - } - } else { - Reply($client, "refused\n", $userinput); - - } -# ------------------------------------------------------------------ Hanging up - } elsif (($userinput =~ /^exit/) || - ($userinput =~ /^init/)) { # no restrictions. - &logthis( - "Client $clientip ($clientname) hanging up: $userinput"); - print $client "bye\n"; - $client->shutdown(2); # shutdown the socket forcibly. - $client->close(); - return 0; - -# ---------------------------------- set current host/domain - } elsif ($userinput =~ /^sethost/) { - if (isClient) { - print $client &sethost($userinput)."\n"; - } else { - print $client "refused\n"; - } -#---------------------------------- request file (?) version. - } elsif ($userinput =~/^version/) { - if (isClient) { - print $client &version($userinput)."\n"; - } else { - print $client "refused\n"; - } #------------------------------- is auto-enrollment enabled? - } elsif ($userinput =~/^autorun/) { + if ($userinput =~/^autorun/) { if (isClient) { my ($cmd,$cdom) = split(/:/,$userinput); my $outcome = &localenroll::run($cdom); @@ -3266,7 +3989,8 @@ sub process_request { } else { print $client "refused\n"; } -#--------------------- read and retrieve institutional code format (for support form). +#--------------------- read and retrieve institutional code format +# (for support form). } elsif ($userinput =~/^autoinstcodeformat/) { if (isClient) { my $reply; @@ -3849,14 +4573,14 @@ sub reply { # -------------------------------------------------------------- Talk to lonsql -sub sqlreply { +sub sql_reply { my ($cmd)=@_; - my $answer=subsqlreply($cmd); - if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); } + my $answer=&sub_sql_reply($cmd); + if ($answer eq 'con_lost') { $answer=&sub_sql_reply($cmd); } return $answer; } -sub subsqlreply { +sub sub_sql_reply { my ($cmd)=@_; my $unixsock="mysqlsock"; my $peerfile="$perlvar{'lonSockDir'}/$unixsock"; @@ -4328,7 +5052,8 @@ sub validate_user { # At the end of this function. I'll ensure that it's not still that # value so we don't just wind up returning some accidental value # as a result of executing an unforseen code path that - # did not set $validated. + # did not set $validated. At the end of valid execution paths, + # validated shoule be 1 for success or 0 for failuer. my $validated = -3.14159; @@ -4416,7 +5141,11 @@ sub validate_user { # unless ($validated != -3.14159) { - die "ValidateUser - failed to set the value of validated"; + # I >really really< want to know if this happens. + # since it indicates that user authentication is badly + # broken in some code path. + # + die "ValidateUser - failed to set the value of validated $domain, $user $password"; } return $validated; } @@ -4442,7 +5171,7 @@ sub addline { return $found; } -sub getchat { +sub get_chat { my ($cdom,$cname,$udom,$uname)=@_; my %hash; my $proname=&propath($cdom,$cname); @@ -4467,7 +5196,7 @@ sub getchat { return (@participants,@entries); } -sub chatadd { +sub chat_add { my ($cdom,$cname,$newchat)=@_; my %hash; my $proname=&propath($cdom,$cname); 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.