--- loncom/lond 2004/08/10 22:55:31 1.228
+++ loncom/lond 2004/08/24 05:13:40 1.235
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.228 2004/08/10 22:55:31 foxr Exp $
+# $Id: lond,v 1.235 2004/08/24 05:13:40 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -57,7 +57,7 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.228 $'; #' stupid emacs
+my $VERSION='$Revision: 1.235 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -1756,18 +1756,39 @@ sub fetch_user_file_handler {
my $userinput = "$cmd:$tail";
my $fname = $tail;
- my ($udom,$uname,$ufile)=split(/\//,$fname);
+ my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
my $udir=&propath($udom,$uname).'/userfiles';
unless (-e $udir) {
mkdir($udir,0770);
}
+ Debug("fetch user file for $fname");
if (-e $udir) {
$ufile=~s/^[\.\~]+//;
- $ufile=~s/\///g;
+
+ # IF necessary, create the path right down to the file.
+ # Note that any regular files in the way of this path are
+ # wiped out to deal with some earlier folly of mine.
+
+ my $path = $udir;
+ if ($ufile =~m|(.+)/([^/]+)$|) {
+ my @parts=split('/',$1);
+ foreach my $part (@parts) {
+ $path .= '/'.$part;
+ if( -f $path) {
+ unlink($path);
+ }
+ if ((-e $path)!=1) {
+ mkdir($path,0770);
+ }
+ }
+ }
+
+
my $destname=$udir.'/'.$ufile;
my $transname=$udir.'/'.$ufile.'.in.transit';
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
my $response;
+ Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
alarm(120);
{
my $ua=new LWP::UserAgent;
@@ -1781,6 +1802,7 @@ sub fetch_user_file_handler {
&logthis("LWP GET: $message for $fname ($remoteurl)");
&Failure($client, "failed\n", $userinput);
} else {
+ Debug("Renaming $transname to $destname");
if (!rename($transname,$destname)) {
&logthis("Unable to move $transname to $destname");
unlink($transname);
@@ -1872,6 +1894,1090 @@ sub token_auth_user_file_handler {
}
®ister_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
+
+
+#
+# Unsubscribe from a resource.
+#
+# Parameters:
+# $cmd - The command that got us here.
+# $tail - Tail of the command (remaining parameters).
+# $client - File descriptor connected to client.
+# Returns
+# 0 - Requested to exit, caller should shut down.
+# 1 - Continue processing.
+#
+sub unsubscribe_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput= "$cmd:$tail";
+
+ my ($fname) = split(/:/,$tail); # Split in case there's extrs.
+
+ &Debug("Unsubscribing $fname");
+ if (-e $fname) {
+ &Debug("Exists");
+ &Reply($client, &unsub($fname,$clientip), $userinput);
+ } else {
+ &Failure($client, "not_found\n", $userinput);
+ }
+ return 1;
+}
+®ister_handler("unsub", \&unsubscribe_handler, 0, 1, 0);
+# Subscribe to a resource
+#
+# Parameters:
+# $cmd - The command that got us here.
+# $tail - Tail of the command (remaining parameters).
+# $client - File descriptor connected to client.
+# Returns
+# 0 - Requested to exit, caller should shut down.
+# 1 - Continue processing.
+#
+sub subscribe_handler {
+ my ($cmd, $tail, $client)= @_;
+
+ my $userinput = "$cmd:$tail";
+
+ &Reply( $client, &subscribe($userinput,$clientip), $userinput);
+
+ return 1;
+}
+®ister_handler("sub", \&subscribe_handler, 0, 1, 0);
+
+#
+# Determine the version of a resource (?) Or is it return
+# the top version of the resource? Not yet clear from the
+# code in currentversion.
+#
+# Parameters:
+# $cmd - The command that got us here.
+# $tail - Tail of the command (remaining parameters).
+# $client - File descriptor connected to client.
+# Returns
+# 0 - Requested to exit, caller should shut down.
+# 1 - Continue processing.
+#
+sub current_version_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput= "$cmd:$tail";
+
+ my $fname = $tail;
+ &Reply( $client, ¤tversion($fname)."\n", $userinput);
+ return 1;
+
+}
+®ister_handler("currentversion", \¤t_version_handler, 0, 1, 0);
+
+# Make an entry in a user's activity log.
+#
+# Parameters:
+# $cmd - The command that got us here.
+# $tail - Tail of the command (remaining parameters).
+# $client - File descriptor connected to client.
+# Returns
+# 0 - Requested to exit, caller should shut down.
+# 1 - Continue processing.
+#
+sub activity_log_handler {
+ my ($cmd, $tail, $client) = @_;
+
+
+ my $userinput= "$cmd:$tail";
+
+ my ($udom,$uname,$what)=split(/:/,$tail);
+ chomp($what);
+ my $proname=&propath($udom,$uname);
+ my $now=time;
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/activity.log")) {
+ print $hfh "$now:$clientname:$what\n";
+ &Reply( $client, "ok\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." IO::File->new Failed "
+ ."while attempting log\n",
+ $userinput);
+ }
+
+ return 1;
+}
+register_handler("log", \&activity_log_handler, 0, 1, 0);
+
+#
+# Put a namespace entry in a user profile hash.
+# My druthers would be for this to be an encrypted interaction too.
+# anything that might be an inadvertent covert channel about either
+# user authentication or user personal information....
+#
+# Parameters:
+# $cmd - The command that got us here.
+# $tail - Tail of the command (remaining parameters).
+# $client - File descriptor connected to client.
+# Returns
+# 0 - Requested to exit, caller should shut down.
+# 1 - Continue processing.
+#
+sub put_user_profile_entry {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
+ if ($namespace ne 'roles') {
+ chomp($what);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_WRCREAT(),"P",$what);
+ if($hashref) {
+ my @pairs=split(/\&/,$what);
+ 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 put\n",
+ $userinput);
+ }
+ } else {
+ &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
+ "while attempting put\n", $userinput);
+ }
+ } else {
+ &Failure( $client, "refused\n", $userinput);
+ }
+
+ return 1;
+}
+®ister_handler("put", \&put_user_profile_entry, 0, 1, 0);
+
+#
+# Increment a profile entry in the user history file.
+# The history contains keyword value pairs. In this case,
+# The value itself is a pair of numbers. The first, the current value
+# the second an increment that this function applies to the current
+# value.
+#
+# Parameters:
+# $cmd - The command that got us here.
+# $tail - Tail of the command (remaining parameters).
+# $client - File descriptor connected to client.
+# Returns
+# 0 - Requested to exit, caller should shut down.
+# 1 - Continue processing.
+#
+sub increment_user_value_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
+ if ($namespace ne 'roles') {
+ chomp($what);
+ my $hashref = &tie_user_hash($udom, $uname,
+ $namespace, &GDBM_WRCREAT(),
+ "P",$what);
+ if ($hashref) {
+ my @pairs=split(/\&/,$what);
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
+ # We could check that we have a number...
+ if (! defined($value) || $value eq '') {
+ $value = 1;
+ }
+ $hashref->{$key}+=$value;
+ }
+ if (untie(%$hashref)) {
+ &Reply( $client, "ok\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
+ "while attempting inc\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting inc\n", $userinput);
+ }
+ } else {
+ &Failure($client, "refused\n", $userinput);
+ }
+
+ return 1;
+}
+®ister_handler("inc", \&increment_user_value_handler, 0, 1, 0);
+
+
+#
+# Put a new role for a user. Roles are LonCAPA's packaging of permissions.
+# Each 'role' a user has implies a set of permissions. Adding a new role
+# for a person grants the permissions packaged with that role
+# to that user when the role is selected.
+#
+# Parameters:
+# $cmd - The command string (rolesput).
+# $tail - The remainder of the request line. For rolesput this
+# consists of a colon separated list that contains:
+# The domain and user that is granting the role (logged).
+# The domain and user that is getting the role.
+# The roles being granted as a set of & separated pairs.
+# each pair a key value pair.
+# $client - File descriptor connected to the client.
+# Returns:
+# 0 - If the daemon should exit
+# 1 - To continue processing.
+#
+#
+sub roles_put_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ( $exedom, $exeuser, $udom, $uname, $what) = split(/:/,$tail);
+
+
+ my $namespace='roles';
+ chomp($what);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_WRCREAT(), "P",
+ "$exedom:$exeuser:$what");
+ #
+ # Log the attempt to set a role. The {}'s here ensure that the file
+ # handle is open for the minimal amount of time. Since the flush
+ # is done on close this improves the chances the log will be an un-
+ # corrupted ordered thing.
+ if ($hashref) {
+ my @pairs=split(/\&/,$what);
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
+ &manage_permissions($key, $udom, $uname,
+ &get_auth_type( $udom, $uname));
+ $hashref->{$key}=$value;
+ }
+ if (untie($hashref)) {
+ &Reply($client, "ok\n", $userinput);
+ } else {
+ &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting rolesput\n", $userinput);
+ }
+ } else {
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting rolesput\n", $userinput);
+ }
+ return 1;
+}
+®ister_handler("rolesput", \&roles_put_handler, 1,1,0); # Encoded client only.
+
+#
+# Deletes (removes) a role for a user. This is equivalent to removing
+# a permissions package associated with the role from the user's profile.
+#
+# Parameters:
+# $cmd - The command (rolesdel)
+# $tail - The remainder of the request line. This consists
+# of:
+# The domain and user requesting the change (logged)
+# The domain and user being changed.
+# The roles being revoked. These are shipped to us
+# as a bunch of & separated role name keywords.
+# $client - The file handle open on the client.
+# Returns:
+# 1 - Continue processing
+# 0 - Exit.
+#
+sub roles_delete_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
+ &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
+ "what = ".$what);
+ my $namespace='roles';
+ chomp($what);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_WRCREAT(), "D",
+ "$exedom:$exeuser:$what");
+
+ if ($hashref) {
+ my @rolekeys=split(/\&/,$what);
+
+ foreach my $key (@rolekeys) {
+ delete $hashref->{$key};
+ }
+ if (untie(%$hashref)) {
+ &Reply($client, "ok\n", $userinput);
+ } else {
+ &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting rolesdel\n", $userinput);
+ }
+ } else {
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting rolesdel\n", $userinput);
+ }
+
+ return 1;
+}
+®ister_handler("rolesdel", \&roles_delete_handler, 1,1, 0); # Encoded client only
+
+# Unencrypted get from a user's profile database. See
+# GetProfileEntryEncrypted for a version that does end-to-end encryption.
+# This function retrieves a keyed item from a specific named database in the
+# user's directory.
+#
+# Parameters:
+# $cmd - Command request keyword (get).
+# $tail - Tail of the command. This is a colon separated list
+# consisting of the domain and username that uniquely
+# identifies the profile,
+# The 'namespace' which selects the gdbm file to
+# do the lookup in,
+# & separated list of keys to lookup. Note that
+# the values are returned as an & separated list too.
+# $client - File descriptor open on the client.
+# Returns:
+# 1 - Continue processing.
+# 0 - Exit.
+#
+sub get_profile_entry {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput= "$cmd:$tail";
+
+ my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
+ chomp($what);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_READER());
+ if ($hashref) {
+ my @queries=split(/\&/,$what);
+ my $qresult='';
+
+ for (my $i=0;$i<=$#queries;$i++) {
+ $qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.
+ }
+ $qresult=~s/\&$//; # Remove trailing & from last lookup.
+ if (untie(%$hashref)) {
+ &Reply($client, "$qresult\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting get\n", $userinput);
+ }
+ } else {
+ if ($!+0 == 2) { # +0 coerces errno -> number 2 is ENOENT
+ &Failure($client, "error:No such file or ".
+ "GDBM reported bad block error\n", $userinput);
+ } else { # Some other undifferentiated err.
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting get\n", $userinput);
+ }
+ }
+ return 1;
+}
+®ister_handler("get", \&get_profile_entry, 0,1,0);
+
+#
+# Process the encrypted get request. Note that the request is sent
+# in clear, but the reply is encrypted. This is a small covert channel:
+# information about the sensitive keys is given to the snooper. Just not
+# information about the values of the sensitive key. Hmm if I wanted to
+# know these I'd snoop for the egets. Get the profile item names from them
+# and then issue a get for them since there's no enforcement of the
+# requirement of an encrypted get for particular profile items. If I
+# were re-doing this, I'd force the request to be encrypted as well as the
+# reply. I'd also just enforce encrypted transactions for all gets since
+# that would prevent any covert channel snooping.
+#
+# Parameters:
+# $cmd - Command keyword of request (eget).
+# $tail - Tail of the command. See GetProfileEntry
# for more information about this.
+# $client - File open on the client.
+# Returns:
+# 1 - Continue processing
+# 0 - server should exit.
+sub get_profile_entry_encrypted {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
+ chomp($what);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_READER());
+ if ($hashref) {
+ my @queries=split(/\&/,$what);
+ my $qresult='';
+ for (my $i=0;$i<=$#queries;$i++) {
+ $qresult.="$hashref->{$queries[$i]}&";
+ }
+ if (untie(%$hashref)) {
+ $qresult=~s/\&$//;
+ if ($cipher) {
+ my $cmdlength=length($qresult);
+ $qresult.=" ";
+ my $encqresult='';
+ for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
+ $encqresult.= unpack("H16",
+ $cipher->encrypt(substr($qresult,
+ $encidx,
+ 8)));
+ }
+ &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
+ } else {
+ &Failure( $client, "error:no_key\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting eget\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting eget\n", $userinput);
+ }
+
+ return 1;
+}
+®ister_handler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);
+#
+# Deletes a key in a user profile database.
+#
+# Parameters:
+# $cmd - Command keyword (del).
+# $tail - Command tail. IN this case a colon
+# separated list containing:
+# The domain and user that identifies uniquely
+# the identity of the user.
+# The profile namespace (name of the profile
+# database file).
+# & separated list of keywords to delete.
+# $client - File open on client socket.
+# Returns:
+# 1 - Continue processing
+# 0 - Exit server.
+#
+#
+
+sub delete_profile_entry {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "cmd:$tail";
+
+ my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
+ chomp($what);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_WRCREAT(),
+ "D",$what);
+ if ($hashref) {
+ my @keys=split(/\&/,$what);
+ foreach my $key (@keys) {
+ delete($hashref->{$key});
+ }
+ if (untie(%$hashref)) {
+ &Reply($client, "ok\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting del\n", $userinput);
+ }
+ } else {
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting del\n", $userinput);
+ }
+ return 1;
+}
+®ister_handler("del", \&delete_profile_entry, 0, 1, 0);
+#
+# List the set of keys that are defined in a profile database file.
+# A successful reply from this will contain an & separated list of
+# the keys.
+# Parameters:
+# $cmd - Command request (keys).
+# $tail - Remainder of the request, a colon separated
+# list containing domain/user that identifies the
+# user being queried, and the database namespace
+# (database filename essentially).
+# $client - File open on the client.
+# Returns:
+# 1 - Continue processing.
+# 0 - Exit the server.
+#
+sub get_profile_keys {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($udom,$uname,$namespace)=split(/:/,$tail);
+ my $qresult='';
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_READER());
+ if ($hashref) {
+ foreach my $key (keys %$hashref) {
+ $qresult.="$key&";
+ }
+ if (untie(%$hashref)) {
+ $qresult=~s/\&$//;
+ &Reply($client, "$qresult\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting keys\n", $userinput);
+ }
+ } else {
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting keys\n", $userinput);
+ }
+
+ return 1;
+}
+®ister_handler("keys", \&get_profile_keys, 0, 1, 0);
+
+#
+# Dump the contents of a user profile database.
+# Note that this constitutes a very large covert channel too since
+# the dump will return sensitive information that is not encrypted.
+# The naive security assumption is that the session negotiation ensures
+# our client is trusted and I don't believe that's assured at present.
+# Sure want badly to go to ssl or tls. Of course if my peer isn't really
+# a LonCAPA node they could have negotiated an encryption key too so >sigh<.
+#
+# Parameters:
+# $cmd - The command request keyword (currentdump).
+# $tail - Remainder of the request, consisting of a colon
+# separated list that has the domain/username and
+# the namespace to dump (database file).
+# $client - file open on the remote client.
+# Returns:
+# 1 - Continue processing.
+# 0 - Exit the server.
+#
+sub dump_profile_database {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($udom,$uname,$namespace) = split(/:/,$tail);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_READER());
+ if ($hashref) {
+ # Structure of %data:
+ # $data{$symb}->{$parameter}=$value;
+ # $data{$symb}->{'v.'.$parameter}=$version;
+ # since $parameter will be unescaped, we do not
+ # have to worry about silly parameter names...
+
+ my $qresult='';
+ my %data = (); # A hash of anonymous hashes..
+ while (my ($key,$value) = each(%$hashref)) {
+ my ($v,$symb,$param) = split(/:/,$key);
+ next if ($v eq 'version' || $symb eq 'keys');
+ next if (exists($data{$symb}) &&
+ exists($data{$symb}->{$param}) &&
+ $data{$symb}->{'v.'.$param} > $v);
+ $data{$symb}->{$param}=$value;
+ $data{$symb}->{'v.'.$param}=$v;
+ }
+ if (untie(%$hashref)) {
+ while (my ($symb,$param_hash) = each(%data)) {
+ while(my ($param,$value) = each (%$param_hash)){
+ next if ($param =~ /^v\./); # Ignore versions...
+ #
+ # Just dump the symb=value pairs separated by &
+ #
+ $qresult.=$symb.':'.$param.'='.$value.'&';
+ }
+ }
+ chop($qresult);
+ &Reply($client , "$qresult\n", $userinput);
+ } else {
+ &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting currentdump\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting currentdump\n", $userinput);
+ }
+
+ return 1;
+}
+®ister_handler("currentdump", \&dump_profile_database, 0, 1, 0);
+
+#
+# Dump a profile database with an optional regular expression
+# to match against the keys. In this dump, no effort is made
+# to separate symb from version information. Presumably the
+# databases that are dumped by this command are of a different
+# structure. Need to look at this and improve the documentation of
+# both this and the currentdump handler.
+# Parameters:
+# $cmd - The command keyword.
+# $tail - All of the characters after the $cmd:
+# These are expected to be a colon
+# separated list containing:
+# domain/user - identifying the user.
+# namespace - identifying the database.
+# regexp - optional regular expression
+# that is matched against
+# database keywords to do
+# selective dumps.
+# $client - Channel open on the client.
+# Returns:
+# 1 - Continue processing.
+# Side effects:
+# response is written to $client.
+#
+sub dump_with_regexp {
+ my ($cmd, $tail, $client) = @_;
+
+
+ my $userinput = "$cmd:$tail";
+
+ my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);
+ if (defined($regexp)) {
+ $regexp=&unescape($regexp);
+ } else {
+ $regexp='.';
+ }
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_READER());
+ if ($hashref) {
+ my $qresult='';
+ while (my ($key,$value) = each(%$hashref)) {
+ if ($regexp eq '.') {
+ $qresult.=$key.'='.$value.'&';
+ } else {
+ my $unescapeKey = &unescape($key);
+ if (eval('$unescapeKey=~/$regexp/')) {
+ $qresult.="$key=$value&";
+ }
+ }
+ }
+ if (untie(%$hashref)) {
+ chop($qresult);
+ &Reply($client, "$qresult\n", $userinput);
+ } else {
+ &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting dump\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting dump\n", $userinput);
+ }
+
+ return 1;
+}
+
+®ister_handler("dump", \&dump_with_regexp, 0, 1, 0);
+
+# Store a set of key=value pairs associated with a versioned name.
+#
+# Parameters:
+# $cmd - Request command keyword.
+# $tail - Tail of the request. This is a colon
+# separated list containing:
+# domain/user - User and authentication domain.
+# namespace - Name of the database being modified
+# rid - Resource keyword to modify.
+# what - new value associated with rid.
+#
+# $client - Socket open on the client.
+#
+#
+# Returns:
+# 1 (keep on processing).
+# Side-Effects:
+# Writes to the client
+sub store_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail";
+
+ my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);
+ if ($namespace ne 'roles') {
+
+ chomp($what);
+ my @pairs=split(/\&/,$what);
+ my $hashref = &tie_user_hash($udom, $uname, $namespace,
+ &GDBM_WRCREAT(), "P",
+ "$rid:$what");
+ if ($hashref) {
+ my $now = time;
+ my @previouskeys=split(/&/,$hashref->{"keys:$rid"});
+ my $key;
+ $hashref->{"version:$rid"}++;
+ my $version=$hashref->{"version:$rid"};
+ my $allkeys='';
+ foreach my $pair (@pairs) {
+ my ($key,$value)=split(/=/,$pair);
+ $allkeys.=$key.':';
+ $hashref->{"$version:$rid:$key"}=$value;
+ }
+ $hashref->{"$version:$rid:timestamp"}=$now;
+ $allkeys.='timestamp';
+ $hashref->{"$version:keys:$rid"}=$allkeys;
+ if (untie($hashref)) {
+ &Reply($client, "ok\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting store\n", $userinput);
+ }
+ } else {
+ &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting store\n", $userinput);
+ }
+ } else {
+ &Failure($client, "refused\n", $userinput);
+ }
+
+ return 1;
+}
+®ister_handler("store", \&store_handler, 0, 1, 0);
+#
+# Dump out all versions of a resource that has key=value pairs associated
+# with it for each version. These resources are built up via the store
+# command.
+#
+# Parameters:
+# $cmd - Command keyword.
+# $tail - Remainder of the request which consists of:
+# domain/user - User and auth. domain.
+# namespace - name of resource database.
+# rid - Resource id.
+# $client - socket open on the client.
+#
+# Returns:
+# 1 indicating the caller should not yet exit.
+# Side-effects:
+# Writes a reply to the client.
+# The reply is a string of the following shape:
+# version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2...
+# Where the 1 above represents version 1.
+# this continues for all pairs of keys in all versions.
+#
+#
+#
+#
+sub restore_handler {
+ my ($cmd, $tail, $client) = @_;
+
+ my $userinput = "$cmd:$tail"; # Only used for logging purposes.
+
+ my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+ chomp($rid);
+ my $proname=&propath($udom,$uname);
+ my $qresult='';
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
+ &GDBM_READER(),0640)) {
+ my $version=$hash{"version:$rid"};
+ $qresult.="version=$version&";
+ my $scope;
+ for ($scope=1;$scope<=$version;$scope++) {
+ my $vkeys=$hash{"$scope:keys:$rid"};
+ my @keys=split(/:/,$vkeys);
+ my $key;
+ $qresult.="$scope:keys=$vkeys&";
+ foreach $key (@keys) {
+ $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
+ }
+ }
+ if (untie(%hash)) {
+ $qresult=~s/\&$//;
+ &Reply( $client, "$qresult\n", $userinput);
+ } else {
+ &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
+ "while attempting restore\n", $userinput);
+ }
+ } else {
+ &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
+ "while attempting restore\n", $userinput);
+ }
+
+ return 1;
+
+
+}
+®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,$value)=split(/=/,$pair);
+ $hashref->{$key}=$value.':'.$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);
+#
+#
+#
#---------------------------------------------------------------
#
# Getting, decoding and dispatching requests:
@@ -1887,7 +2993,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);
@@ -1986,727 +3092,8 @@ sub process_request {
#------------------- Commands not yet in spearate handlers. --------------
-
-# ----------------------------------------------------------------- unsubscribe
- if ($userinput =~ /^unsub/) {
- if(isClient) {
- my ($cmd,$fname)=split(/:/,$userinput);
- if (-e $fname) {
- print $client &unsub($fname,$clientip);
- } else {
- print $client "not_found\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------------- subscribe
- } elsif ($userinput =~ /^sub/) {
- if(isClient) {
- print $client &subscribe($userinput,$clientip);
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------- current version
- } elsif ($userinput =~ /^currentversion/) {
- if(isClient) {
- my ($cmd,$fname)=split(/:/,$userinput);
- print $client ¤tversion($fname)."\n";
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------------------- log
- } elsif ($userinput =~ /^log/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
- chomp($what);
- my $proname=propath($udom,$uname);
- my $now=time;
- {
- my $hfh;
- if ($hfh=IO::File->new(">>$proname/activity.log")) {
- print $hfh "$now:$clientname:$what\n";
- print $client "ok\n";
- } else {
- print $client "error: ".($!+0)
- ." IO::File->new Failed "
- ."while attempting log\n";
- }
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------------------- put
- } elsif ($userinput =~ /^put/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$what)
- =split(/:/,$userinput,5);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- if ($namespace ne 'roles') {
- chomp($what);
- my $proname=propath($udom,$uname);
- my $now=time;
- my @pairs=split(/\&/,$what);
- my %hash;
- if (tie(%hash,'GDBM_File',
- "$proname/$namespace.db",
- &GDBM_WRCREAT(),0640)) {
- unless ($namespace=~/^nohist\_/) {
- my $hfh;
- if ($hfh=IO::File->new(">>$proname/$namespace.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 put\n";
- }
- } else {
- print $client "error: ".($!)
- ." tie(GDBM) Failed ".
- "while attempting put\n";
- }
- } else {
- print $client "refused\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------------- inc
- } elsif ($userinput =~ /^inc:/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$what)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- if ($namespace ne 'roles') {
- chomp($what);
- my $proname=propath($udom,$uname);
- my $now=time;
- my @pairs=split(/\&/,$what);
- my %hash;
- if (tie(%hash,'GDBM_File',
- "$proname/$namespace.db",
- &GDBM_WRCREAT(),0640)) {
- unless ($namespace=~/^nohist\_/) {
- my $hfh;
- if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
- }
- foreach my $pair (@pairs) {
- my ($key,$value)=split(/=/,$pair);
- # We could check that we have a number...
- if (! defined($value) || $value eq '') {
- $value = 1;
- }
- $hash{$key}+=$value;
- }
- if (untie(%hash)) {
- print $client "ok\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) failed ".
- "while attempting inc\n";
- }
- } else {
- print $client "error: ".($!)
- ." tie(GDBM) Failed ".
- "while attempting inc\n";
- }
- } else {
- print $client "refused\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# -------------------------------------------------------------------- rolesput
- } elsif ($userinput =~ /^rolesput/) {
- if(isClient) {
- &Debug("rolesput");
- if ($wasenc==1) {
- my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
- =split(/:/,$userinput);
- &Debug("cmd = ".$cmd." exedom= ".$exedom.
- "user = ".$exeuser." udom=".$udom.
- "what = ".$what);
- my $namespace='roles';
- chomp($what);
- my $proname=propath($udom,$uname);
- my $now=time;
- my @pairs=split(/\&/,$what);
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
- {
- my $hfh;
- if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
- print $hfh "P:$now:$exedom:$exeuser:$what\n";
- }
- }
-
- foreach my $pair (@pairs) {
- my ($key,$value)=split(/=/,$pair);
- &ManagePermissions($key, $udom, $uname,
- &get_auth_type( $udom,
- $uname));
- $hash{$key}=$value;
- }
- if (untie(%hash)) {
- print $client "ok\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting rolesput\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting rolesput\n";
- }
- } else {
- print $client "refused\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# -------------------------------------------------------------------- rolesdel
- } elsif ($userinput =~ /^rolesdel/) {
- if(isClient) {
- &Debug("rolesdel");
- if ($wasenc==1) {
- my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
- =split(/:/,$userinput);
- &Debug("cmd = ".$cmd." exedom= ".$exedom.
- "user = ".$exeuser." udom=".$udom.
- "what = ".$what);
- my $namespace='roles';
- chomp($what);
- my $proname=propath($udom,$uname);
- my $now=time;
- my @rolekeys=split(/\&/,$what);
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
- {
- my $hfh;
- if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
- print $hfh "D:$now:$exedom:$exeuser:$what\n";
- }
- }
- foreach my $key (@rolekeys) {
- delete $hash{$key};
- }
- if (untie(%hash)) {
- print $client "ok\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting rolesdel\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting rolesdel\n";
- }
- } else {
- print $client "refused\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------------------- get
- } elsif ($userinput =~ /^get/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$what)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- chomp($what);
- my @queries=split(/\&/,$what);
- my $proname=propath($udom,$uname);
- my $qresult='';
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.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 get\n";
- }
- } else {
- if ($!+0 == 2) {
- print $client "error:No such file or ".
- "GDBM reported bad block error\n";
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting get\n";
- }
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------------------ eget
- } elsif ($userinput =~ /^eget/) {
- if (isClient) {
- my ($cmd,$udom,$uname,$namespace,$what)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- chomp($what);
- my @queries=split(/\&/,$what);
- my $proname=propath($udom,$uname);
- my $qresult='';
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
- for (my $i=0;$i<=$#queries;$i++) {
- $qresult.="$hash{$queries[$i]}&";
- }
- if (untie(%hash)) {
- $qresult=~s/\&$//;
- if ($cipher) {
- my $cmdlength=length($qresult);
- $qresult.=" ";
- my $encqresult='';
- for
- (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
- $encqresult.=
- unpack("H16",
- $cipher->encrypt(substr($qresult,$encidx,8)));
- }
- print $client "enc:$cmdlength:$encqresult\n";
- } else {
- print $client "error:no_key\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting eget\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting eget\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------------------- del
- } elsif ($userinput =~ /^del/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$what)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- chomp($what);
- my $proname=propath($udom,$uname);
- my $now=time;
- my @keys=split(/\&/,$what);
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
- unless ($namespace=~/^nohist\_/) {
- my $hfh;
- if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; }
- }
- foreach my $key (@keys) {
- delete($hash{$key});
- }
- if (untie(%hash)) {
- print $client "ok\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting del\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting del\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ------------------------------------------------------------------------ keys
- } elsif ($userinput =~ /^keys/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$namespace)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- my $proname=propath($udom,$uname);
- my $qresult='';
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
- foreach my $key (keys %hash) {
- $qresult.="$key&";
- }
- if (untie(%hash)) {
- $qresult=~s/\&$//;
- print $client "$qresult\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting keys\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting keys\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ----------------------------------------------------------------- dumpcurrent
- } elsif ($userinput =~ /^currentdump/) {
- if (isClient) {
- my ($cmd,$udom,$uname,$namespace)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- my $qresult='';
- my $proname=propath($udom,$uname);
- my %hash;
- if (tie(%hash,'GDBM_File',
- "$proname/$namespace.db",
- &GDBM_READER(),0640)) {
- # Structure of %data:
- # $data{$symb}->{$parameter}=$value;
- # $data{$symb}->{'v.'.$parameter}=$version;
- # since $parameter will be unescaped, we do not
- # have to worry about silly parameter names...
- my %data = ();
- while (my ($key,$value) = each(%hash)) {
- my ($v,$symb,$param) = split(/:/,$key);
- next if ($v eq 'version' || $symb eq 'keys');
- next if (exists($data{$symb}) &&
- exists($data{$symb}->{$param}) &&
- $data{$symb}->{'v.'.$param} > $v);
- $data{$symb}->{$param}=$value;
- $data{$symb}->{'v.'.$param}=$v;
- }
- if (untie(%hash)) {
- while (my ($symb,$param_hash) = each(%data)) {
- while(my ($param,$value) = each (%$param_hash)){
- next if ($param =~ /^v\./);
- $qresult.=$symb.':'.$param.'='.$value.'&';
- }
- }
- chop($qresult);
- print $client "$qresult\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting currentdump\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting currentdump\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
- }
-# ------------------------------------------------------------------------ dump
- } elsif ($userinput =~ /^dump/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$regexp)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- if (defined($regexp)) {
- $regexp=&unescape($regexp);
- } else {
- $regexp='.';
- }
- my $qresult='';
- my $proname=propath($udom,$uname);
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
- while (my ($key,$value) = each(%hash)) {
- if ($regexp eq '.') {
- $qresult.=$key.'='.$value.'&';
- } else {
- my $unescapeKey = &unescape($key);
- if (eval('$unescapeKey=~/$regexp/')) {
- $qresult.="$key=$value&";
- }
- }
- }
- if (untie(%hash)) {
- chop($qresult);
- print $client "$qresult\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting dump\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting dump\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# ----------------------------------------------------------------------- store
- } elsif ($userinput =~ /^store/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$rid,$what)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- if ($namespace ne 'roles') {
- chomp($what);
- my $proname=propath($udom,$uname);
- my $now=time;
- my @pairs=split(/\&/,$what);
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
- unless ($namespace=~/^nohist\_/) {
- my $hfh;
- if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
- print $hfh "P:$now:$rid:$what\n";
- }
- }
- my @previouskeys=split(/&/,$hash{"keys:$rid"});
- my $key;
- $hash{"version:$rid"}++;
- my $version=$hash{"version:$rid"};
- my $allkeys='';
- foreach my $pair (@pairs) {
- my ($key,$value)=split(/=/,$pair);
- $allkeys.=$key.':';
- $hash{"$version:$rid:$key"}=$value;
- }
- $hash{"$version:$rid:timestamp"}=$now;
- $allkeys.='timestamp';
- $hash{"$version:keys:$rid"}=$allkeys;
- if (untie(%hash)) {
- print $client "ok\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting store\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting store\n";
- }
- } else {
- print $client "refused\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# --------------------------------------------------------------------- restore
- } elsif ($userinput =~ /^restore/) {
- if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$rid)
- =split(/:/,$userinput);
- $namespace=~s/\//\_/g;
- $namespace=~s/\W//g;
- chomp($rid);
- my $proname=propath($udom,$uname);
- my $qresult='';
- my %hash;
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
- my $version=$hash{"version:$rid"};
- $qresult.="version=$version&";
- my $scope;
- for ($scope=1;$scope<=$version;$scope++) {
- my $vkeys=$hash{"$scope:keys:$rid"};
- my @keys=split(/:/,$vkeys);
- my $key;
- $qresult.="$scope:keys=$vkeys&";
- foreach $key (@keys) {
- $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
- }
- }
- if (untie(%hash)) {
- $qresult=~s/\&$//;
- print $client "$qresult\n";
- } else {
- print $client "error: ".($!+0)
- ." untie(GDBM) Failed ".
- "while attempting restore\n";
- }
- } else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed ".
- "while attempting restore\n";
- }
- } else {
- Reply($client, "refused\n", $userinput);
-
- }
-# -------------------------------------------------------------------- chatsend
- } elsif ($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 ($userinput =~ /^idput/) {
if(isClient) {
my ($cmd,$udom,$what)=split(/:/,$userinput);
chomp($what);
@@ -2838,24 +3225,6 @@ sub process_request {
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.'<br />';
- }
- } else {
- $dirContents = "No directory found\n";
- }
- print $client $dirContents."\n";
- } else {
- Reply($client, "refused\n", $userinput);
- }
# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {
if(isClient) {
@@ -2929,21 +3298,21 @@ sub process_request {
return 0;
# ---------------------------------- set current host/domain
- } elsif ($userinput =~ /^sethost:/) {
+ } elsif ($userinput =~ /^sethost/) {
if (isClient) {
print $client &sethost($userinput)."\n";
} else {
print $client "refused\n";
}
#---------------------------------- request file (?) version.
- } elsif ($userinput =~/^version:/) {
+ } elsif ($userinput =~/^version/) {
if (isClient) {
print $client &version($userinput)."\n";
} else {
print $client "refused\n";
}
#------------------------------- is auto-enrollment enabled?
- } elsif ($userinput =~/^autorun:/) {
+ } elsif ($userinput =~/^autorun/) {
if (isClient) {
my ($cmd,$cdom) = split(/:/,$userinput);
my $outcome = &localenroll::run($cdom);
@@ -2952,7 +3321,7 @@ sub process_request {
print $client "0\n";
}
#------------------------------- get official sections (for auto-enrollment).
- } elsif ($userinput =~/^autogetsections:/) {
+ } elsif ($userinput =~/^autogetsections/) {
if (isClient) {
my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
my @secs = &localenroll::get_sections($coursecode,$cdom);
@@ -2962,7 +3331,7 @@ sub process_request {
print $client "refused\n";
}
#----------------------- validate owner of new course section (for auto-enrollment).
- } elsif ($userinput =~/^autonewcourse:/) {
+ } elsif ($userinput =~/^autonewcourse/) {
if (isClient) {
my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
@@ -2971,7 +3340,7 @@ sub process_request {
print $client "refused\n";
}
#-------------- validate course section in schedule of classes (for auto-enrollment).
- } elsif ($userinput =~/^autovalidatecourse:/) {
+ } elsif ($userinput =~/^autovalidatecourse/) {
if (isClient) {
my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
@@ -2980,7 +3349,7 @@ sub process_request {
print $client "refused\n";
}
#--------------------------- create password for new user (for auto-enrollment).
- } elsif ($userinput =~/^autocreatepassword:/) {
+ } elsif ($userinput =~/^autocreatepassword/) {
if (isClient) {
my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
my ($create_passwd,$authchk);
@@ -2990,7 +3359,7 @@ sub process_request {
print $client "refused\n";
}
#--------------------------- read and remove temporary files (for auto-enrollment).
- } elsif ($userinput =~/^autoretrieve:/) {
+ } elsif ($userinput =~/^autoretrieve/) {
if (isClient) {
my ($cmd,$filename) = split(/:/,$userinput);
my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
@@ -3016,7 +3385,7 @@ sub process_request {
print $client "refused\n";
}
#--------------------- read and retrieve institutional code format (for support form).
- } elsif ($userinput =~/^autoinstcodeformat:/) {
+ } elsif ($userinput =~/^autoinstcodeformat/) {
if (isClient) {
my $reply;
my($cmd,$cdom,$course) = split(/:/,$userinput);
@@ -3598,14 +3967,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";
@@ -3934,7 +4303,7 @@ sub make_new_child {
# user - Name of the user for which the role is being put.
# authtype - The authentication type associated with the user.
#
-sub ManagePermissions
+sub manage_permissions
{
my ($request, $domain, $user, $authtype) = @_;
@@ -4191,7 +4560,7 @@ sub addline {
return $found;
}
-sub getchat {
+sub get_chat {
my ($cdom,$cname,$udom,$uname)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
@@ -4216,7 +4585,7 @@ sub getchat {
return (@participants,@entries);
}
-sub chatadd {
+sub chat_add {
my ($cdom,$cname,$newchat)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
@@ -4775,7 +5144,7 @@ Place in B<logs/lond.log>
stores hash in namespace
-=item rolesput
+=item rolesputy
put a role into a user's environment