#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

# ACLAgentInterface to get ACLs from Un*x file permissions.

use strict;
require Exporter;
#require AutoLoader;

$W3C::Rnodes::UnixPermAgent::REVISION = '$Id: UnixPermAgent.pm,v 1.20 2005/03/17 05:56:53 eric Exp $ ';

package W3C::Rnodes::UnixPermAgent; # implements W3C::Rnodes::ACLAgentInterface
use W3C::Util::Object;
use W3C::Util::Exception;

use W3C::Rnodes::ACL qw($ACCESS_FOR_FILESYSTEM_READ
			$ACCESS_FOR_FILESYSTEM_WRITE
			$ACCESS_FOR_FILESYSTEM_EXEC
			&parseURI &buildDBRuleId
			$TYPE_NONE);

use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK);
@ISA = qw(W3C::Util::NamedParmObject Exporter); # AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 0.10;
$DSLI = 'adpO';

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    my $props = $self->{-properties};
    bless ($self, $class);
    if (!ref $props) {
	$props = new W3C::Util::Properties($props);
    }

    $props->defaultToI('database', 'w3c');
    $self->{URI_MAP} = $props->getI('map');
    return $self;
}

############################## ACLAgentInterface ##############################

sub disconnect {}

#####
# getAclsFor - creates new entry for resource, acls set according to file permissions
#
# return (new id, redirection location)

sub getAclsFor {
    my ($self, $aclDB, $resourcesP, $wildcard, $recursive) = @_;

    # Copy resources as we will be playing around with them.
    my @resources = ref $resourcesP eq 'ARRAY' ? @$resourcesP : $resourcesP;

    my $count = 0;
    foreach my $resource (@resources) {
	## don't cracl anything that came from another source (like the database)
	#next if ($aclDB->getResourceAttribute($resource, 'source'));

	# look up rules for this resource
	my ($protocol, $host, $portStr, $path) = &parseURI($resource);
	&throw(new W3C::Util::MalformedUriException(-uri => $resource)) if (!defined $protocol);
	my @aliases = $self->{-properties}->getI('canonicalHost');
	push (@aliases, $self->{-properties}->getI('alias'));
	my $matchedAlias = undef;
	foreach my $checkAlias (@aliases) {
	    (($matchedAlias = $checkAlias) && last) if ($checkAlias =~ m/\A ~ \s* (.*) \Z/x && $host =~ m/$1/);
	    (($matchedAlias = $checkAlias) && last) if ($host =~ m/$checkAlias/);
	}
	# find the best mapping for this resource
	my ($bestRule, $mapped) = $self->_mapURI($resource);
	if (!defined $bestRule) {
	    &throw(new W3C::Rnodes::UnixPermAgent::NoMapForResourceException(-host => $host, -uri => $resource));
	}

	# redirect if that rule is for another host
	if (!$matchedAlias) {
	    &throw(new W3C::Rnodes::UnixPermAgent::NeedRedirectException(-target => $bestRule->[1], -uri => $resource));
	}

	if ($wildcard && $resource =~ m/\Q$wildcard\E/) {
	    my $tmp = $resource;
	    $tmp =~ s/\Q$wildcard\E//g;
	    $mapped = $self->_mapToLocalFile($mapped, $tmp =~ m/\/$/);
	    $self->_matchWildcard($aclDB, $wildcard, $recursive, \$count, $bestRule, $mapped);
	} else {
	    # the found object hasn't got a wildcard
	    my $isDir = -d $mapped;
	    if ($isDir) {
		if ($mapped !~ m/\/\Z/) {
		    $mapped .= '/';
		    $resource .= '/';
		}
		#next if ($aclDB->getResourceAttribute($resource, 'source'));
	    }
	    $mapped = $self->_mapToLocalFile($mapped, $isDir);
	    $count += $self->_getFileSystemRulesFor($aclDB, $mapped, $resource, $isDir);
	}
    }
    return $count;
}

sub _matchWildcard {
    my ($self, $aclDB, $wildcard, $recursive, $pCount, $bestRule, $mapped) = @_;
    # complicated heuristics if cracling with a wildcard
    my $recursiveCandidate = $recursive && $mapped =~ m/\Q$wildcard\E$/;
    if ($wildcard ne '*') {
	$mapped =~ s/\*/\\\*/g;				# quote '*'s and
	$mapped =~ s/\Q$wildcard\E/\*/g;	# change wildcard to unquoted '*'
    }
    my $baseDir = $mapped;
    # strip off '/*' from directory
    $baseDir =~ s/(\/)?\*\Z//;
    # put it back on. (wasn't that fun?)
    $mapped = $baseDir.'/*' if (-d $baseDir && $mapped =~ m/\*\Z/);
    # sanitize the file name - escape everything that isn't a word char, /, or *
    $mapped =~ s/([^\w\/\*\-\.])/\\$1/g;
    # get a list of files covered by the wildcard
    my @fileList = `ls -ad $mapped`; # glob($mapped) doesn't work where csh is not installed
    map {chomp} @fileList;
    # include the base directory (if it is indeed a directory)
    unshift (@fileList, $baseDir) if (-d $baseDir);
    foreach my $singleFile (@fileList) {
	chomp $singleFile;
	my $isDir = -d $singleFile;
	my $adornedWithSlash = $singleFile;
	$adornedWithSlash .= '/' if ($isDir);
	my $singleResource = $adornedWithSlash;
	# urlencode each segment.
	$singleResource =~ s/([^\/a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
	# map each file according to the rule returned by earlier call to _mapURI
	my $changed;
	my $map = '$changed = $singleResource'." =~ $bestRule->[4]";
	eval $map;
	&throw(new W3C::Util::Exception(-message => "Could not execute file to uri map \"$map\" on \"$singleResource\"")) if (!$changed);
	# some overloaded filesystems need to perform standardized maps (eg CVS)
	$singleResource = $self->_mapFromLocalFile($singleResource, $isDir);
	# don't include the file if there's already a rule for it
	#next if ($aclDB->rulesFor($singleResource));
	# map from file systems rules (rwx) to chacl rules (get post ...)
	$$pCount += $self->_getFileSystemRulesFor($aclDB, $adornedWithSlash, $singleResource, $isDir);
	if ($recursiveCandidate && $isDir && $baseDir ne $singleFile) {
	    my ($bestRule, $mapped) = $self->_mapURI($singleResource.$wildcard);
	    $self->_matchWildcard($aclDB, $wildcard, $recursive, $pCount, $bestRule, $mapped);
	    # don't support for redirect and noMap exceptions this deep
	}
    }
}

sub _mapToLocalFile {
    my ($self, $singleResource, $isdir) = @_;
    return CGI::unescape($singleResource);
}

sub _mapFromLocalFile {
    my ($self, $singleResource, $isdir) = @_;
    return $singleResource;
}

sub setAclFor {
    my ($self, $resources, $acl, $creations, $updates) = @_;
    &throw(new W3C::Util::NotImplementedException());
}

sub deleteAclFor {
    my ($self, $resources, $deletions) = @_;
    &throw(new W3C::Util::NotImplementedException());
}

sub setAuthResAttrs {
    my ($self, $aclDB, $requiredAccess, $user, $ip) = @_;
    &throw(new W3C::Util::NotImplementedException());
}

sub _mapURI {
    my $self = shift;
    my $resource = shift;
    if (defined($self->{URI_MAP}) && @{$self->{URI_MAP}} > 0) {
    } else {
	$self->{URI_MAP} = &{$self->{-getFilepathMaps}}();
	#$self->{DB}->executeArrayQuery($self->{URI_MAP}, 'select uri,chacl,filepath,map,fileToURI from uriMaps');
	## reverse sort the map regexps so the first match is the most-specific
	#$self->{URI_MAP} = [sort {$b->[0] cmp $a->[0]} @{$self->{URI_MAP}}];
    }
    # return the first (most precise) rule matching $resource
#    map {return $_ if ($resource =~ m/\A $_->[0] \Z/x)} @{$self->{URI_MAP}};
#    map {return ($_, $resource) if ($resource =~ $_->[3])} @{$self->{URI_MAP}};
    foreach my $mapEntry (@{$self->{URI_MAP}}) {
	my $changed;
	my $map = '$changed = $resource'." =~ $mapEntry->[3]";
#	my $changed = $resource =~ $mapEntry->[3];
	eval $map;
	return ($mapEntry, $resource) if ($changed);
    }
    return undef;
}

sub _getFileSystemRulesFor {
    my ($self, $aclDB, $mapped, $resource, $isDir) = @_;
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($mapped);
    &throw(new W3C::Util::NoSuchFileException(-file => $mapped, -uri => $resource)) if (!defined $dev);
    my $count = 0;
    $count += $self->_mapFileToAccess($aclDB, $resource, 'U', $isDir, ($mode & 0700) >> 6, $uid);
    $count += $self->_mapFileToAccess($aclDB, $resource, 'G', $isDir, ($mode & 070) >> 3, $gid);
    $count += $self->_mapFileToAccess($aclDB, $resource, 'A', $isDir, ($mode & 07), 1); # 1 is the known id for "A" (all rule)

    return $count;
}

#####
# _mapFileToAccess - find certHTTP rules corresponding to file mode

sub _mapFileToAccess {
    my ($self, $aclDB, $resource, $filesystemType, $filesystemIsdir, $filesystemMode, $filesystemId) = @_;

    # determine access level for this filesystem mode
    my ($count, $access) = (0, 0);
    $access |= $ACCESS_FOR_FILESYSTEM_READ if ($filesystemMode & 4);
    $access |= $ACCESS_FOR_FILESYSTEM_WRITE if ($filesystemMode & 2);
    $access |= $ACCESS_FOR_FILESYSTEM_EXEC if ($filesystemMode & 1 && !$filesystemIsdir);
    return $count if ($access == 0);

    # find what ids get granted these access rights
    my ($webIds, $webTypes) = &{$self->{-getFilesystemIdsAndTypes}}($filesystemId, $filesystemType);
    #$self->{DB}->executeQuery(\@webIds, \%webTypes, 
    #			      'select value,ids.type from fileSystemIds,ids where fileSystemIds.id='.$filesystemId.
    #			      ' and fileSystemIds.type='.$self->{DB}->escape($filesystemType).' and ids.id=fileSystemIds.webId');

    if (!@$webIds) {
	my $exception = new W3C::Util::Exception(-message => "no map for $resource");
	my $webId = $filesystemId;
	$aclDB->addDBRule($resource, &buildDBRuleId($filesystemType, "unixID:$filesystemId"), $access, {'source'=> $self->{-sourceID}});
    }

    # add the corresponding rules to the above access and ids
    foreach my $webId (@$webIds) {
	$aclDB->addDBRule($resource, &buildDBRuleId($webTypes->{$webId}, $webId), $access, {'source'=> $self->{-sourceID}});
	$count ++;
    }
    return $count;
}

1;

__END__

=head1 NAME

W3C::Rnodes::UnixPermAgent - 

=head1 SYNOPSIS

  use W3C::Rnodes::UnixPermAgent;

=head1 DESCRIPTION

<description>

This module is part of the W3C::Rnodes CPAN module.

=head1 AUTHOR

Eric Prud\'hommeaux <eric@w3.org>

=head1 SEE ALSO

W3C::Rnodes::ACL(3) perl(1).

=cut
