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

# W3C::Rnodes::ACL - Constants, human-readable strings, and URI manipulation functions used in ACLs.

use strict;
require Exporter;
#require AutoLoader;

$W3C::Rnodes::ACL::REVISION = '$Id: ACL.pm,v 1.16 2005/03/16 06:03:49 eric Exp $ ';
@W3C::Rnodes::ACL::AclDataFormatException::ISA = qw(W3C::Util::Exception);

package W3C::Rnodes::ACL;
use W3C::Util::Exception;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK);
@ISA = qw(Exporter); # AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw($TYPE_NONE $TYPE_ALL $TYPE_USER 
		$TYPE_GROUP $TYPE_IP $TYPE_ORG $TYPE_TEMP
		$ACCESS_CHACL $ACCESS_RACL $ACCESS_DELEGATE 
		$ACCESS_HEAD $ACCESS_GET $ACCESS_PUT 
		$ACCESS_POST $ACCESS_DELETE $ACCESS_CONNECT 
		$ACCESS_OPTIONS $ACCESS_TRACE $ACCESS_FULL
		$MACRO_RULEID $MACRO_RULENAME $MACRO_RULEICON 
		$MACRO_RULES $MACRO_RULEDESC
		$MACRO_RULE_TYPE $MACRO_RULE_ID $MACRO_RULE_ACCESS
		%TEXT_TYPE %TYPE_TEXT @DISPLAY_TYPES @DISPLAY_TYPES2
		%ACCESS_TEXT @ACCESS_LIST
		$ACCESS_FOR_FILESYSTEM_READ $ACCESS_FOR_FILESYSTEM_WRITE 
		$ACCESS_FOR_FILESYSTEM_EXEC
		$ACCESS_FOR_FILESYSTEM_RW $ACCESS_FOR_FILESYSTEM_RX 
		$ACCESS_FOR_FILESYSTEM_RWX
		$ACL_SCHEMA_URI
		&parseDBRule &parseDBRule2 &parseDBRuleId &parseURI
		&accessBitFieldList &buildDBRuleId &buildDBRuleId2
		&normalizeAccessStringList &accessStringList
		&addDBRule &delDBRule
		);
$VERSION = 0.10;
$DSLI = 'adpO';

#####
# constants

use vars qw($TYPE_NONE $TYPE_ALL $TYPE_USER 
	    $TYPE_GROUP $TYPE_IP $TYPE_ORG $TYPE_TEMP);

$TYPE_NONE = 'N';
$TYPE_ALL = 'A';
$TYPE_USER = 'U';
$TYPE_GROUP = 'G';
$TYPE_IP = 'I';
$TYPE_ORG = 'O';
$TYPE_TEMP = 'T';

use vars qw(@DISPLAY_TYPES @DISPLAY_TYPES2);
use vars qw(%TYPE_TEXT %TEXT_TYPE);
@DISPLAY_TYPES = ($TYPE_GROUP, $TYPE_ORG, $TYPE_IP, $TYPE_USER, $TYPE_ALL);
@DISPLAY_TYPES2 = ('group', 'org', 'ip', 'user');
%TYPE_TEXT = (
		 'N' => 'nobody',
		 'A' => 'all',
		 'G' => 'group',
		 'U' => 'user',
		 'O' => 'org',
		 'I' => 'ip',
		 'T' => '-temp-',
		 );
%TEXT_TYPE = (
		 'nobody' => 'N',
		 'all' => 'A',	# transition from this
		 'key' => 'A',	# to this
		 #'key' => 'K',	# and eventually to this
		 'group' => 'G',
		 'user' => 'U',
		 'org' => 'O',
		 'ip' => 'I',
		 '-temp-' => 'T',
		 );

#####
# acl access

use vars qw($ACCESS_CHACL $ACCESS_RACL $ACCESS_DELEGATE $ACCESS_HEAD
	    $ACCESS_GET $ACCESS_PUT $ACCESS_POST $ACCESS_DELETE
	    $ACCESS_CONNECT $ACCESS_OPTIONS $ACCESS_TRACE $ACCESS_FULL);
$ACCESS_CHACL	= 0x001;
$ACCESS_RACL	= 0x002;
$ACCESS_DELEGATE= 0x004;
$ACCESS_HEAD	= 0x010;
$ACCESS_GET	= 0x020;
$ACCESS_PUT	= 0x040;
$ACCESS_POST	= 0x080;
$ACCESS_DELETE	= 0x100;
$ACCESS_CONNECT	= 0x200;
$ACCESS_OPTIONS	= 0x400;
$ACCESS_TRACE	= 0x800;
$ACCESS_FULL	= 0xFF3;

# default system access for file access
use vars qw($ACCESS_FOR_FILESYSTEM_READ $ACCESS_FOR_FILESYSTEM_WRITE $ACCESS_FOR_FILESYSTEM_EXEC 
	    $ACCESS_FOR_FILESYSTEM_RW $ACCESS_FOR_FILESYSTEM_RX $ACCESS_FOR_FILESYSTEM_RWX);
$ACCESS_FOR_FILESYSTEM_READ = $ACCESS_RACL|$ACCESS_HEAD|$ACCESS_GET|$ACCESS_OPTIONS|$ACCESS_TRACE;
$ACCESS_FOR_FILESYSTEM_WRITE = $ACCESS_CHACL|$ACCESS_RACL|$ACCESS_HEAD|$ACCESS_GET|$ACCESS_PUT|$ACCESS_DELETE|
    $ACCESS_CONNECT|$ACCESS_OPTIONS|$ACCESS_TRACE;
$ACCESS_FOR_FILESYSTEM_EXEC = $ACCESS_RACL|$ACCESS_GET|$ACCESS_POST|$ACCESS_OPTIONS|$ACCESS_TRACE;
$ACCESS_FOR_FILESYSTEM_RW = $ACCESS_FOR_FILESYSTEM_READ|$ACCESS_FOR_FILESYSTEM_WRITE;
$ACCESS_FOR_FILESYSTEM_RX = $ACCESS_FOR_FILESYSTEM_READ|$ACCESS_FOR_FILESYSTEM_EXEC;
$ACCESS_FOR_FILESYSTEM_RWX = $ACCESS_FOR_FILESYSTEM_READ|$ACCESS_FOR_FILESYSTEM_WRITE|$ACCESS_FOR_FILESYSTEM_EXEC;

use vars qw(@ACCESS_LIST %ACCESS_TEXT %ACCESS_BITS);
@ACCESS_LIST = ($ACCESS_CHACL, $ACCESS_RACL, $ACCESS_HEAD, $ACCESS_GET, 
		$ACCESS_CONNECT, $ACCESS_OPTIONS, $ACCESS_TRACE, 
		$ACCESS_PUT, $ACCESS_POST, $ACCESS_DELETE);

use vars qw($ACL_SCHEMA_URI);
$ACL_SCHEMA_URI = 'http://www.w3.org/2001/02/acls/ns#';

%ACCESS_TEXT = ($ACCESS_CHACL	 => "${ACL_SCHEMA_URI}chacl", 
		$ACCESS_RACL	 => "${ACL_SCHEMA_URI}racl", 
		$ACCESS_HEAD	 => "${ACL_SCHEMA_URI}head", 
		$ACCESS_GET	 => "${ACL_SCHEMA_URI}get", 
		$ACCESS_PUT	 => "${ACL_SCHEMA_URI}put", 
		$ACCESS_POST	 => "${ACL_SCHEMA_URI}post", 
		$ACCESS_DELETE	 => "${ACL_SCHEMA_URI}delete", 
		$ACCESS_CONNECT => "${ACL_SCHEMA_URI}connect", 
		$ACCESS_OPTIONS => "${ACL_SCHEMA_URI}options", 
		$ACCESS_TRACE	 => "${ACL_SCHEMA_URI}trace", 
		);

%ACCESS_BITS = ("${ACL_SCHEMA_URI}chacl"   => $ACCESS_CHACL, 
		"${ACL_SCHEMA_URI}racl"	   => $ACCESS_RACL, 
		"${ACL_SCHEMA_URI}head"	   => $ACCESS_HEAD, 
		"${ACL_SCHEMA_URI}get"	   => $ACCESS_GET, 
		"${ACL_SCHEMA_URI}put"	   => $ACCESS_PUT, 
		"${ACL_SCHEMA_URI}post"	   => $ACCESS_POST, 
		"${ACL_SCHEMA_URI}delete"  => $ACCESS_DELETE, 
		"${ACL_SCHEMA_URI}connect" => $ACCESS_CONNECT, 
		"${ACL_SCHEMA_URI}options" => $ACCESS_OPTIONS, 
		"${ACL_SCHEMA_URI}trace"   => $ACCESS_TRACE, 
		);

use vars qw($RuleCache);
$RuleCache = 'http://www.w3.org/Systems/db/webId?';

use vars qw($USERDETAILS_STATUS_DELEGATE $IDS_STOPS_DISABLED $IDS_STOPS_NEED_CONF $USERDETAILS_STATUS_VALIDUSER);
$USERDETAILS_STATUS_DELEGATE	= $ACCESS_DELEGATE;
$IDS_STOPS_DISABLED		= 0x01;
$IDS_STOPS_NEED_CONF		= 0x10;
$USERDETAILS_STATUS_VALIDUSER	= 0x20;

use vars qw($MACRO_RULEID $MACRO_RULENAME $MACRO_RULEICON $MACRO_RULES 
	   $MACRO_RULEDESC $MACRO_RULE_TYPE $MACRO_RULE_ID $MACRO_RULE_ACCESS);
$MACRO_RULENAME = 0;
$MACRO_RULEID = 1;
$MACRO_RULEICON = 2;
$MACRO_RULES = 3;
$MACRO_RULEDESC = 4;

$MACRO_RULE_TYPE = 0;
$MACRO_RULE_ID = 1;
$MACRO_RULE_ACCESS = 2;

################################################################################

#####
# accessList - listize a set of access priveleges

sub accessList { # static
    my ($number) = @_;
    my @ret;
    my $count = 0;
    for (my $mask = 1; $mask <= $ACCESS_FULL; $mask *= 2) {
	push (@ret, $mask) if (($mask | $number) == $number);
    }
    return \@ret;
}

#####
# accessStringList - stringize a set of access priveleges
# setup for chaclCGI but may be usefull elsewhere so I put it here

sub accessStringList { # static
    my ($number) = @_;
    my @ret;
    my $accesses = &accessList($number);
    foreach my $access (@$accesses) {
	push(@ret, $ACCESS_TEXT{$access});
    }
    return @ret;
}

sub accessBitFieldList { # static
    my (@accessStrings) = @_;
    my $ret = 0;
    foreach my $access (@accessStrings) {
	$ret |= $ACCESS_BITS{$access};
    }
    return $ret;
}

sub normalizeAccessStringList { # static
    my ($accessString) = @_;
    return 'no' if (ref $accessString ne 'ARRAY');
    return &accessStringList(&accessBitFieldList(@$accessString));
}

sub buildDBRuleId { # static
    my ($type, $name) = @_;
    if ($name =~ m/^[\w\d\:\.]+$/) {
	return $RuleCache.$TYPE_TEXT{$type}.'='.$name;
    }
    &throw(new W3C::Util::Exception(-message => "bad format for name \"$name\""));
}

sub buildDBRuleId2 { # static
    my ($type, $name) = @_;
    if ($name =~ m/^[\w\d\:\.]+$/) {
	return $RuleCache.$type.'='.$name;
    }
    &throw(new W3C::Util::Exception(-message => "bad format for name \"$name\""));
}

sub parseDBRuleId { # static
    my ($id) = @_;
    my $ruleCache = $RuleCache;
    if ($id =~ m/\A \Q$ruleCache\E ([^\=]+) \= (.*) \Z/x) {
	return ($1, $2);
    }
    &throw(new W3C::Rnodes::ACL::AclDataFormatException(-expected => $ruleCache.'<type>=<id>', -got => $id));
}

sub parseDBRule { # static
    my ($rule) = @_;
    my $id = $rule->id;
    my ($type, $name) = &parseDBRuleId($id);
    if (!$name) {
	&throw(new W3C::Util::Exception(-message => "bad format for rule \"$id\""));
    }
    $type = $TEXT_TYPE{$type};
    my $access = &accessBitFieldList($rule->access);
    return ($type, $name, $access);
}

sub parseDBRule2 { # static
    my ($rule) = @_;
    my $id = $rule->id;
    my ($type, $name) = &parseDBRuleId($id);
    &throw(new W3C::Util::Exception(-message => "bad format for rule \"$id\"")) if (!$name);
#    $type = $TEXT_TYPE{$type};
#    my $access = &accessBitFieldList($rule->access);
    return ($type, $name, $rule->access);
}

#####
# parseURI - split URI into (protocol,host,port string,resource,query string)

sub parseURI { # static
    my ($resource) = @_;
    return undef if ($resource !~ m/\A (\w+) :\/\/ ([a-zA-Z0-9_\.\-]+) (:\d+)? (\/[^\?]*) (\?.*)? \Z/x);
    return (lc $1,lc $2,$3,$4,$5); # @@@ is protocol case-sensitive?
}

package W3C::Rnodes::ACL::AclDataFormatException;
#use vars qw(@ISA);
#@ISA = qw(W3C::Util::Exception);
sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-expected') if (!$self->{-expected});
    $self->missingParm('-got') if (!$self->{-got});
#    $self->optionalParm('-documentLocator') if (!$self->{-documenLocator});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'Data format error: expected "'.$_[0]->{-expected}.'" but got "'.$_[0]->{-got}.'"';}
sub getExpected {return $_[0]->{-expected};}
sub getGot {return $_[0]->{-got};}
sub getDocumentLocator {return $_[0]->{-documentLocator};}

package W3C::Rnodes::UnixPermAgent::NeedRedirectException;
use vars qw(@ISA);
@ISA = qw(W3C::Util::ResourceException);
sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-target') if (!$self->{-target});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'Resource '.$_[0]->{-uri}.' needs to redirect to: "'.$_[0]->{-target}.'"';}
sub getTarget {return $_[0]->{-target};}

package W3C::Rnodes::UnixPermAgent::NoMapForResourceException;
use vars qw(@ISA);
@ISA = qw(W3C::Util::ResourceException);
sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-host') if (!$self->{-host});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'No map for resource"'.$_[0]->{-uri}.'" at host "'.$_[0]->{-host}.'"';}
sub getHost {return $_[0]->{-host};}

package W3C::Rnodes::ACL;

1;

__END__

=head1 NAME

W3C::Rnodes::ACL - 

=head1 SYNOPSIS

  use W3C::Rnodes::ACL;

=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::(3) perl(1).

=cut
