--- loncom/lond 2004/08/16 10:54:19 1.229 +++ loncom/lond 2004/08/18 11:31:50 1.232 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.229 2004/08/16 10:54:19 foxr Exp $ +# $Id: lond,v 1.232 2004/08/18 11:31:50 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 = 0; # Non zero to enable debug log entries. +my $DEBUG = 1; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.229 $'; #' stupid emacs +my $VERSION='$Revision: 1.232 $'; #' 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); @@ -1902,7 +1924,780 @@ sub unsubscribe_handler { 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); +# +# #--------------------------------------------------------------- # # Getting, decoding and dispatching requests: @@ -2018,571 +2813,8 @@ sub process_request { - -# ------------------------------------------------------------------- subscribe - if ($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 ($userinput =~ /^chatsend/) { if(isClient) { my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); &chatadd($cdom,$cnum,$newpost); @@ -2948,21 +3180,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); @@ -2971,7 +3203,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); @@ -2981,7 +3213,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); @@ -2990,7 +3222,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); @@ -2999,7 +3231,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); @@ -3009,7 +3241,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; @@ -3035,7 +3267,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); @@ -3953,7 +4185,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) = @_; @@ -4794,7 +5026,7 @@ Place in B stores hash in namespace -=item rolesput +=item rolesputy put a role into a user's environment