# HG changeset patch
# User sergey
# Date 1349653057 -14400
# Node ID 6d8092d8ce1b1a0331cc2414f7aa8657f891a7c1
# Parent 47f77e6409f7923454c6ed1a01a2fbdcd6ea9f78
*reworked IMPL::Security
*reworked IMPL::Web::Security
*refactoring
diff -r 47f77e6409f7 -r 6d8092d8ce1b .includepath
--- a/.includepath Sat Sep 29 02:34:47 2012 +0400
+++ b/.includepath Mon Oct 08 03:37:37 2012 +0400
@@ -1,5 +1,5 @@
-
-
-
-
-
+
+
+
+
+
diff -r 47f77e6409f7 -r 6d8092d8ce1b .settings/org.eclipse.wst.xsl.core.prefs
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.settings/org.eclipse.wst.xsl.core.prefs Mon Oct 08 03:37:37 2012 +0400
@@ -0,0 +1,11 @@
+CHECK_CALL_TEMPLATES=2
+CHECK_XPATHS=2
+CIRCULAR_REF=2
+DUPLICATE_PARAMETER=2
+EMPTY_PARAM=1
+MISSING_INCLUDE=2
+MISSING_PARAM=1
+NAME_ATTRIBUTE_EMPTY=2
+NAME_ATTRIBUTE_MISSING=2
+TEMPLATE_CONFLICT=2
+eclipse.preferences.version=1
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Class/MemberInfo.pm
--- a/Lib/IMPL/Class/MemberInfo.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Class/MemberInfo.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,22 +1,13 @@
package IMPL::Class::MemberInfo;
use strict;
-use IMPL::_core::version;
use parent qw(IMPL::Object::Accessor);
require IMPL::Exception;
-use constant {
- MOD_PUBLIC => 1,
- MOD_PROTECTED => 2,
- MOD_PRIVATE => 3
-};
-
-#TODO remove Virtual
__PACKAGE__->mk_accessors(
qw(
Name
Access
- Virtual
Class
Frozen
Implementor
@@ -33,7 +24,6 @@
$this->Attributes({}) unless defined $this->Attributes;
$this->Frozen(0);
- $this->Virtual(0) unless defined $this->Virtual;
$this->Access(3) unless $this->Access;
}
@@ -76,12 +66,6 @@
Атрибут доступа ( public | private | protected )
-=item C<[get,set] Virtual>
-
-Default false.
-
-Флаг виртуальности.
-
=item C<[get,set] Class>
Класс владелец
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Class/Meta.pm
--- a/Lib/IMPL/Class/Meta.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Class/Meta.pm Mon Oct 08 03:37:37 2012 +0400
@@ -87,19 +87,21 @@
*{"${class}::${name}"} = sub {
my $self = shift;
+ $self = ref $self || $self;
+
if (@_ > 0) {
- $self = ref $self || $self;
-
if ($class ne $self) {
$self->static_accessor_clone( $name => $_[0] ); # define own class data
} else {
$value = $_[0];
}
} else {
- $self->static_accessor_clone($name => clone($value));
+ return $self ne $class
+ ? $self->static_accessor_clone($name => clone($value))
+ : $value;
}
};
- $value
+ return $value;
};
sub static_accessor_inherit {
@@ -121,7 +123,8 @@
} else {
$value ;
}
- }
+ };
+ return $value;
}
sub static_accessor_own {
@@ -145,7 +148,9 @@
return $value;
}
}
- }
+ };
+
+ return $value;
}
sub _find_class_data {
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Class/MethodInfo.pm
--- a/Lib/IMPL/Class/MethodInfo.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Class/MethodInfo.pm Mon Oct 08 03:37:37 2012 +0400
@@ -6,8 +6,8 @@
__PACKAGE__->PassThroughArgs;
__PACKAGE__->mk_accessors(qw(
- ReturnType
- Parameters
+ returnType
+ parameters
));
1;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Class/Property/Base.pm
--- a/Lib/IMPL/Class/Property/Base.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Class/Property/Base.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,9 +1,7 @@
package IMPL::Class::Property::Base;
use strict;
-use IMPL::Class::Property;
-
-require IMPL::Class::Member;
+use IMPL::Const qw(:all);
sub factoryParams { qw($class $name $set $get $validator) };
@@ -18,9 +16,9 @@
my $validator_code = '$this->$validator(@_);';
my %access_code = (
- IMPL::Class::Member::MOD_PUBLIC , "",
- IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);",
- IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;"
+ ACCESS_PUBLIC , "",
+ ACCESS_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);",
+ ACCESS_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;"
);
my $virtual_call = q(
@@ -36,14 +34,14 @@
my %accessors;
if (not ref $param) {
- if ($param & prop_list) {
- $accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : undef;
- $accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : undef;
+ if ($param & PROP_LIST) {
+ $accessors{get} = ($param & PROP_GET) ? $self->GenerateGetList(@params) : undef;
+ $accessors{set} = ($param & PROP_SET) ? $self->GenerateSetList(@params) : undef;
} else {
- $accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : undef;
- $accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : undef;
+ $accessors{get} = ($param & PROP_GET) ? $self->GenerateGet(@params) : undef;
+ $accessors{set} = ($param & PROP_SET) ? $self->GenerateSet(@params) : undef;
}
- $accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : "";
+ $accessors{owner} = (($param & PROP_OWNERSET) == PROP_OWNERSET) ? $owner_check : "";
} elsif (UNIVERSAL::isa($param,'HASH')) {
$accessors{get} = $param->{get} ? $custom_accessor_get : undef;
$accessors{set} = $param->{set} ? $custom_accessor_set : undef;
@@ -108,6 +106,10 @@
1;
}
+sub Implement {
+ my ($self,$spec) = @_;
+}
+
# extract from property info: class, name, get_accessor, set_accessor, validator
sub RemapFactoryParams {
my ($self,$propInfo) = @_;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Class/PropertyInfo.pm
--- a/Lib/IMPL/Class/PropertyInfo.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Class/PropertyInfo.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,6 +1,5 @@
package IMPL::Class::PropertyInfo;
use strict;
-use IMPL::_core::version;
use parent qw(IMPL::Class::MemberInfo);
@@ -31,10 +30,6 @@
$implementor = $this->SelectImplementor();
- if (my $class = ref $implementor ? undef : $implementor) {
- eval "require $class; 1;" or die $@ unless $LoadedModules{$class}++;
- }
-
$this->Implementor($implementor);
}
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Code/Binding.pm
--- a/Lib/IMPL/Code/Binding.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Code/Binding.pm Mon Oct 08 03:37:37 2012 +0400
@@ -11,7 +11,7 @@
$vars ||= [];
- die ArgumentException( vars => 'A reference to an array is required')
+ die ArgumentException->new( vars => 'A reference to an array is required')
unless ref $vars eq 'ARRAY';
m/^\w+$/ or die ArgumentException->new( vars => 'A valid variable name is required', $_ )
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Code/Loader.pm
--- a/Lib/IMPL/Code/Loader.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Code/Loader.pm Mon Oct 08 03:37:37 2012 +0400
@@ -2,7 +2,7 @@
use strict;
use warnings;
-use IMPL::lang qw(:declare :constants);
+use IMPL::Const qw(:prop);
use IMPL::declare {
require => {
@@ -12,7 +12,12 @@
base => {
'IMPL::Object' => undef,
'IMPL::Object::Autofill' => '@_'
- }
+ },
+ props => [
+ verifyNames => PROP_RO,
+ prefix => PROP_RO,
+ _pending => PROP_RW
+ ]
};
my $default;
@@ -25,12 +30,12 @@
$safe ||= new IMPL::Code::Loader(verifyNames => 1);
}
-BEGIN {
- public property verifyNames => PROP_GET | PROP_OWNERSET;
- public property prefix => PROP_GET | PROP_OWNERSET;
+sub CTOR {
+ my ($this) = @_;
+
+ $this->_pending({});
}
-
sub Require {
my ($this,$package) = @_;
@@ -44,6 +49,19 @@
my $file = join('/', split(/::/,$package)) . ".pm";
require $file;
+
+ return $package;
+}
+
+sub GetFullName {
+ my ($this,$package) = @_;
+
+ if ($this->verifyNames) {
+ $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/
+ or die ArgumentException->new(package => 'Invalid package name') ;
+ }
+
+ return $this->prefix . '::' . $package if $this->prefix;
}
1;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Const.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Const.pm Mon Oct 08 03:37:37 2012 +0400
@@ -0,0 +1,55 @@
+package IMPL::Const;
+use strict;
+
+use parent qw(Exporter);
+
+our %EXPORT_TAGS = (
+ all => [
+ qw(
+ &ACCESS_PUBLIC
+ &ACCESS_PROTECTED
+ &ACCESS_PRIVATE
+ &PROP_GET
+ &PROP_SET
+ &PROP_OWNERSET
+ &PROP_LIST
+ &PROP_ALL
+ )
+ ],
+ prop => [
+ qw(
+ &PROP_GET
+ &PROP_SET
+ &PROP_OWNERSET
+ &PROP_LIST
+ &PROP_ALL
+ &PROP_RO
+ &PROP_RW
+ )
+ ],
+ access => [
+ qw(
+ &ACCESS_PUBLIC
+ &ACCESS_PROTECTED
+ &ACCESS_PRIVATE
+ )
+ ]
+
+);
+
+our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } };
+
+use constant {
+ ACCESS_PUBLIC => 1,
+ ACCESS_PROTECTED => 2,
+ ACCESS_PRIVATE => 3,
+ PROP_GET => 1,
+ PROP_SET => 2,
+ PROP_OWNERSET => 10,
+ PROP_LIST => 4,
+ PROP_ALL => 3,
+ PROP_RW => 3,
+ PROP_RO => 11
+};
+
+1;
\ No newline at end of file
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/DOM/Navigator/SchemaNavigator.pm
--- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Mon Oct 08 03:37:37 2012 +0400
@@ -86,7 +86,7 @@
# return found node schema
return $node;
} else {
- return undef; # abort navigation
+ return; # abort navigation
}
#}
}
@@ -103,7 +103,7 @@
if ($this->Current->isa('IMPL::DOM::Schema::SimpleType') or
$this->Current->isa('IMPL::DOM::Schema::ComplexType')
) {
- # we a redirected
+ # we are redirected
return $this->GetNodeFromHistory(-1);
} else {
return $this->Current;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/DOM/Schema.pm
--- a/Lib/IMPL/DOM/Schema.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/DOM/Schema.pm Mon Oct 08 03:37:37 2012 +0400
@@ -2,20 +2,23 @@
use strict;
use warnings;
-require IMPL::DOM::Schema::ComplexNode;
-require IMPL::DOM::Schema::ComplexType;
-require IMPL::DOM::Schema::SimpleNode;
-require IMPL::DOM::Schema::SimpleType;
-require IMPL::DOM::Schema::Node;
-require IMPL::DOM::Schema::AnyNode;
-require IMPL::DOM::Schema::NodeList;
-require IMPL::DOM::Schema::NodeSet;
-require IMPL::DOM::Schema::Property;
-require IMPL::DOM::Schema::SwitchNode;
-require IMPL::DOM::Schema::Validator;
-require IMPL::DOM::Navigator::Builder;
-require IMPL::DOM::XMLReader;
-require IMPL::DOM::Schema::InflateFactory;
+use IMPL::require {
+ ComplexNode => 'IMPL::DOM::Schema::ComplexNode',
+ ComplexType => 'IMPL::DOM::Schema::ComplexType',
+ SimpleNode => 'IMPL::DOM::Schema::SimpleNode',
+ SimpleType => 'IMPL::DOM::Schema::SimpleType',
+ Node => 'IMPL::DOM::Schema::Node',
+ AnyNode => 'IMPL::DOM::Schema::AnyNode',
+ NodeList => 'IMPL::DOM::Schema::NodeList',
+ NodeSet => 'IMPL::DOM::Schema::NodeSet',
+ Property => 'IMPL::DOM::Schema::Property',
+ SwitchNode => 'IMPL::DOM::Schema::SwitchNode',
+ Validator => 'IMPL::DOM::Schema::Validator',
+ Builder => 'IMPL::DOM::Navigator::Builder',
+ XMLReader => 'IMPL::DOM::XMLReader',
+ InflateFactory => 'IMPL::DOM::Schema::InflateFactory',
+ Loader => 'Code::Loader'
+};
use parent qw(IMPL::DOM::Document);
use IMPL::Class::Property;
@@ -32,6 +35,8 @@
public _direct property BaseSchemas => prop_get | owner_set;
}
+my $validatorLoader = Loader->new(prefix => Validator, verifyNames => 1);
+
sub resolveType {
$_[0]->{$_TypesMap}->{$_[1]};
}
@@ -48,10 +53,9 @@
die new IMPL::Exception('Invalid node class') unless $class->isa('IMPL::DOM::Node');
if ($class->isa('IMPL::DOM::Schema::Validator')) {
- $class = "IMPL::DOM::Schema::Validator::$nodeName";
+ $class = $validatorLoader->GetFullName($nodeName);
unless (eval {$class->can('new')}) {
- eval "require $class; 1;";
- my $e = $@;
+ $validatorLoader->Require($nodeName);
die new IMPL::Exception("Invalid validator",$class,$e) if $e;
}
}
@@ -84,8 +88,8 @@
my $class = ref $this || $this;
- my $reader = new IMPL::DOM::XMLReader(
- Navigator => new IMPL::DOM::Navigator::Builder(
+ my $reader = Reader->(
+ Navigator => Builder->new(
$class,
$class->MetaSchema
),
@@ -112,7 +116,7 @@
sub Validate {
my ($this,$node) = @_;
- if ( my ($schemaNode) = $this->selectNodes(sub { $_->isa('IMPL::DOM::Schema::Node') and $_[0]->name eq $node->nodeName })) {
+ if ( my ($schemaNode) = $this->selectNodes(sub { $_->isa(Node) and $_[0]->name eq $node->nodeName })) {
$schemaNode->Validate($node);
} else {
return new IMPL::DOM::Schema::ValidationError(Node => $node, Message=> "A specified document (%Node.nodeName%) doesn't match the schema");
@@ -125,103 +129,103 @@
return $schema if $schema;
- $schema = new IMPL::DOM::Schema;
+ $schema = Schema->new();
$schema->appendRange(
- IMPL::DOM::Schema::ComplexNode->new(name => 'schema')->appendRange(
- IMPL::DOM::Schema::NodeSet->new()->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'ComplexType', type => 'ComplexType', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange(
- IMPL::DOM::Schema::Property->new(name => 'source')
+ ComplexNode->new(name => 'schema')->appendRange(
+ NodeSet->new()->appendRange(
+ Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'ComplexType', type => 'ComplexType', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'),
+ SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange(
+ Property->new(name => 'source')
)
),
),
- IMPL::DOM::Schema::ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange(
- IMPL::DOM::Schema::NodeSet->new()->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::SwitchNode->new(minOccur => 0, maxOccur => 1)->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'AnyNode', type => 'AnyNode'),
- IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode')
+ ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange(
+ NodeSet->new()->appendRange(
+ Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'),
+ SwitchNode->new(minOccur => 0, maxOccur => 1)->appendRange(
+ Node->new(name => 'AnyNode', type => 'AnyNode'),
+ Node->new(name => 'SwitchNode',type => 'SwitchNode')
)
)
),
- IMPL::DOM::Schema::ComplexType->new(type => 'SwitchNode', nativeType => 'IMPL::DOM::Schema::SwitchNode')->appendRange(
- IMPL::DOM::Schema::NodeSet->new()->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type=>'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type=>'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'),
+ ComplexType->new(type => 'SwitchNode', nativeType => 'IMPL::DOM::Schema::SwitchNode')->appendRange(
+ NodeSet->new()->appendRange(
+ Node->new(name => 'ComplexNode', type=>'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'SimpleNode', type=>'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'),
)
),
- IMPL::DOM::Schema::ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange(
- IMPL::DOM::Schema::NodeSet->new()->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'),
- IMPL::DOM::Schema::Node->new(name => 'AnyNode', type => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'),
+ ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange(
+ NodeSet->new()->appendRange(
+ Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'SwitchNode',type => 'SwitchNode', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'),
+ Node->new(name => 'AnyNode', type => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'),
)
),
- IMPL::DOM::Schema::ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange(
- IMPL::DOM::Schema::NodeList->new()->appendRange(
- IMPL::DOM::Schema::SwitchNode->new()->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'NodeSet', type => 'NodeSet'),
- IMPL::DOM::Schema::Node->new(name => 'NodeList',type => 'NodeList'),
+ ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange(
+ NodeList->new()->appendRange(
+ SwitchNode->new()->appendRange(
+ Node->new(name => 'NodeSet', type => 'NodeSet'),
+ Node->new(name => 'NodeList',type => 'NodeList'),
),
- IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0),
- IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator')
+ Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0),
+ AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator')
),
- new IMPL::DOM::Schema::Property(name => 'type')
+ Property->new(name => 'type')
),
- IMPL::DOM::Schema::ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange(
- IMPL::DOM::Schema::NodeList->new()->appendRange(
- IMPL::DOM::Schema::SwitchNode->new()->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'NodeSet', type => 'NodeSet'),
- IMPL::DOM::Schema::Node->new(name => 'NodeList',type => 'NodeList'),
+ ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange(
+ NodeList->new()->appendRange(
+ SwitchNode->new()->appendRange(
+ Node->new(name => 'NodeSet', type => 'NodeSet'),
+ Node->new(name => 'NodeList',type => 'NodeList'),
),
- IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0),
- IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator')
+ Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0),
+ AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator')
),
- new IMPL::DOM::Schema::Property(name => 'name')
+ Property->new(name => 'name')
),
- IMPL::DOM::Schema::ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange(
- IMPL::DOM::Schema::NodeList->new()->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0),
- IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator')
+ ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange(
+ NodeList->new()->appendRange(
+ Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0),
+ AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator')
),
- new IMPL::DOM::Schema::Property(name => 'type'),
- new IMPL::DOM::Schema::Property(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory')
+ Property->new(name => 'type'),
+ Property->(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory')
),
- IMPL::DOM::Schema::ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange(
- IMPL::DOM::Schema::NodeList->new()->appendRange(
- IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0),
- IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator')
+ ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange(
+ NodeList->new()->appendRange(
+ Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0),
+ AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator')
),
- new IMPL::DOM::Schema::Property(name => 'name'),
- new IMPL::DOM::Schema::Property(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory')
+ Property->new(name => 'name'),
+ Property->new(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory')
),
- IMPL::DOM::Schema::ComplexType->new(type => 'Validator', nativeType => 'IMPL::DOM::Schema::Validator')->appendRange(
- IMPL::DOM::Schema::NodeList->new()->appendRange(
- IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0)
+ ComplexType->new(type => 'Validator', nativeType => 'IMPL::DOM::Schema::Validator')->appendRange(
+ NodeList->new()->appendRange(
+ AnyNode->new(maxOccur => 'unbounded', minOccur => 0)
)
),
- IMPL::DOM::Schema::ComplexType->new(type => 'Property', nativeType => 'IMPL::DOM::Schema::Property' )->appendRange(
- IMPL::DOM::Schema::NodeList->new()->appendRange(
- IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0)
+ ComplexType->new(type => 'Property', nativeType => 'IMPL::DOM::Schema::Property' )->appendRange(
+ NodeList->new()->appendRange(
+ AnyNode->new(maxOccur => 'unbounded', minOccur => 0)
),
- IMPL::DOM::Schema::Property->new(name => 'name'),
- new IMPL::DOM::Schema::Property(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory')
+ Property->new(name => 'name'),
+ Property->new(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory')
),
- IMPL::DOM::Schema::SimpleType->new(type => 'Node', nativeType => 'IMPL::DOM::Schema::Node')->appendRange(
- IMPL::DOM::Schema::Property->new(name => 'name'),
- IMPL::DOM::Schema::Property->new(name => 'type')
+ SimpleType->new(type => 'Node', nativeType => 'IMPL::DOM::Schema::Node')->appendRange(
+ Property->new(name => 'name'),
+ Property->new(name => 'type')
),
- IMPL::DOM::Schema::SimpleType->new(type => 'AnyNode', nativeType => 'IMPL::DOM::Schema::AnyNode')
+ SimpleType->new(type => 'AnyNode', nativeType => 'IMPL::DOM::Schema::AnyNode')
);
$schema->Process;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/DOM/Schema/ValidationError.pm
--- a/Lib/IMPL/DOM/Schema/ValidationError.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/DOM/Schema/ValidationError.pm Mon Oct 08 03:37:37 2012 +0400
@@ -62,9 +62,9 @@
=head1 MEMBERS
=over
+
=item C<[get] Node>
-
Узел в документе который привел к ошибке. Как правило это либо простые узлы, либо
узлы, которые не могут присутствоать в данном месте по схеме.
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/DOM/Schema/Validator.pm
--- a/Lib/IMPL/DOM/Schema/Validator.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/DOM/Schema/Validator.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,5 +1,5 @@
package IMPL::DOM::Schema::Validator;
-
+use strict;
use parent qw(IMPL::DOM::Node);
require IMPL::Exception;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Exception.pm
--- a/Lib/IMPL/Exception.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Exception.pm Mon Oct 08 03:37:37 2012 +0400
@@ -10,7 +10,7 @@
require Error;
}
-use parent qw(IMPL::Object::Accessor Error);
+use parent qw(IMPL::Object::Abstract Error Class::Accessor);
BEGIN {
__PACKAGE__->mk_accessors( qw(Message Args CallStack Source) );
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Object.pm
--- a/Lib/IMPL/Object.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Object.pm Mon Oct 08 03:37:37 2012 +0400
@@ -2,6 +2,7 @@
use strict;
use parent qw(IMPL::Object::Abstract);
+require IMPL::Class::Property::Direct;
sub surrogate {
bless {}, ref $_[0] || $_[0];
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Object/Accessor.pm
--- a/Lib/IMPL/Object/Accessor.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Object/Accessor.pm Mon Oct 08 03:37:37 2012 +0400
@@ -2,6 +2,8 @@
use strict;
use parent qw(IMPL::Object::Abstract Class::Accessor IMPL::Class::Meta);
+require IMPL::Class::Property::Accessor;
+
sub new {
my $class = shift;
my $self = $class->Class::Accessor::new( @_ == 1 && ref $_[0] && UNIVERSAL::isa($_[0],'HASH') ? $_[0] : ());
@@ -18,4 +20,5 @@
sub _PropertyImplementor {
'IMPL::Class::Property::Accessor'
}
+
1;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security.pm
--- a/Lib/IMPL/Security.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Security.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,5 +1,11 @@
package IMPL::Security;
-require IMPL::Security::Context;
+use strict;
+use Carp qw(carp);
+
+##VERSION##
+
+require IMPL::Exception;
+require IMPL::Security::AbstractContext;
require IMPL::Security::Rule::RoleCheck;
our @rules = (
@@ -11,7 +17,7 @@
sub AccessCheck {
my ($self, $object, $desiredAccess, $context) = @_;
- $context ||= IMPL::Security::Context->contextCurrent;
+ $context ||= IMPL::Security::AbstractContext->context;
$_->() or return 0 foreach @{$self->Rules};
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/AbstractContext.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Security/AbstractContext.pm Mon Oct 08 03:37:37 2012 +0400
@@ -0,0 +1,152 @@
+package IMPL::Security::AbstractContext;
+use strict;
+use warnings;
+
+use IMPL::Const qw(:prop);
+use IMPL::require {
+ Role => 'IMPL::Security::Role'
+};
+
+use parent qw(IMPL::Class::Meta);
+
+__PACKAGE__->static_accessor_clone(abstractProps => [
+ principal => PROP_RW,
+ rolesAssigned => PROP_RW | PROP_LIST,
+ auth => PROP_RW,
+ authority => PROP_RW
+]);
+
+my $current; # current session if any
+
+sub Impersonate {
+ my ($this,$code) = @_;
+
+ my $old = $current;
+ $current = $this;
+ my $result;
+ my $e;
+
+ {
+ local $@;
+ eval {
+ $result = $code->();
+ };
+ $e = $@;
+ }
+ $current = $old;
+ if($e) {
+ die $e;
+ } else {
+ return $result;
+ }
+}
+
+sub Apply {
+ my ($this) = @_;
+
+ $current = $this;
+}
+
+sub isTrusted {
+ my ($this) = @_;
+
+ if (my $auth = $this->auth) {
+ return $auth->isTrusted;
+ } else {
+ return 0;
+ }
+}
+
+sub Satisfy {
+ my ($this,@roles) = @_;
+
+ my $roleEffective = Role->new ( _effective => scalar $this->rolesAssigned );
+
+ return $roleEffective->Satisfy(@roles);
+}
+
+sub current {
+ $current;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C - контекст безопасности.
+
+=head1 SINOPSYS
+
+=begin code
+
+package MyApp::Model::Session;
+use strict;
+
+use IMPL::delare {
+ base => [
+ 'MyApp::Model::BaseDBO' => '@_',
+ 'IMPL::Security::AbstractContext' => undef
+ ],
+ props {
+ IMPL::Security::AbstractContext->abstractProps,
+ qouta => PROP_GET
+ }
+}
+
+package main;
+
+$app->model->GetSession('546a54df4')->Impersonate(sub{
+ # do something
+});
+
+=end code
+
+=head1 DESCRIPTION
+
+Код приложения, которое выполняется
+
+Являет собой контекст безопасности, описывает пользователя и привелегии, так же
+у программы есть текущий контекст безопасности, по умолчанию он C.
+
+=head1 MEMBERS
+
+=head2 C<[get] principal>
+
+Идентификатор пользователя, владельца контекста.
+
+=head2 C<[get] rolesAssigned>
+
+Список назначенных (активных) ролей пользователю.
+
+=head2 C<[get] auth>
+
+Объект асторизации C, использованный при создании текущего контекста.
+
+=head2 C<[get] authority>
+
+Модуль безопасности, породивший данный контекст. Модуль безопасности, отвечающий
+за создание контекста безопасности должен реализовывать метод
+C
+
+=head2 C<[get] isTrusted>
+
+Возвращает значение является ли контекст доверенным, тоесть клиент
+аутентифицирован и сессия установлена. Если C значит, что сессия была
+начата, однако не установлена до конца.
+
+=head2 C
+
+Делает контекст текущим и выполняет в нем функцию по ссылке C<$code>. По окончании
+выполнения, контекст восстанавливается в предыдущий (не зависимо от того, что
+с ним происходило во время выполнения C<$code>).
+
+=head2 C
+
+Заменяет текущий контекст на себя, но до конца действия метода C, если
+таковой был вызван.
+
+=cut
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/AbstractPrincipal.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Security/AbstractPrincipal.pm Mon Oct 08 03:37:37 2012 +0400
@@ -0,0 +1,14 @@
+package IMPL::Security::AbstractPrincipal;
+use strict;
+
+use parent qw(IMPL::Class::Meta);
+
+use IMPL::Const qw(:prop);
+
+__PACKAGE__->static_accessor_clone(abstractProps => [
+ name => PROP_RW,
+ description => PROP_RW
+]);
+
+1;
+
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/AbstractRole.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Security/AbstractRole.pm Mon Oct 08 03:37:37 2012 +0400
@@ -0,0 +1,65 @@
+package IMPL::Security::AbstractRole;
+use strict;
+
+use IMPL::Const qw(:prop);
+
+use parent qw(IMPL::Class::Meta);
+
+__PACKAGE__->static_accessor_clone( abstractProps => [
+ roleName => PROP_RW,
+ parentRoles => PROP_RW | PROP_LIST
+]);
+
+sub Satisfy {
+ my ($this,@roles) = @_;
+
+ return 1 unless $this->_FilterRoles( @roles );
+ return 0;
+}
+
+sub _FilterRoles {
+ my ($this,@roles) = @_;
+
+ @roles = grep not (ref $_ ? $this->roleName eq $_->roleName : $this->roleName eq $_), @roles;
+
+ @roles = $_->_FilterRoles(@roles) or return foreach $this->parentRoles ;
+
+ return @roles;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C Роль
+
+=head1 DESCRIPTION
+
+Может включать в себя базовые роли.
+Имеется метод для проверки наличия необходимых ролей в текущей роли.
+
+=head1 MEMBERS
+
+=over
+
+=item C<[get] roleName>
+
+Имя роли, ее идентификатор
+
+=item C<[get,list] parentRoles>
+
+Список родительских ролей
+
+=item C
+
+Проверяет наличие ролей указанных ролей из списка @roles_list.
+Допускается использование как самих объектов, так и имен ролей.
+Возвращает 0 в случае неудачи (хотябы одна роль не была удовлетворена), 1 при наличии необходимых ролей.
+
+=back
+
+=cut
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/Auth.pm
--- a/Lib/IMPL/Security/Auth.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Security/Auth.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,4 +1,5 @@
package IMPL::Security::Auth;
+use strict;
use Digest::MD5 qw(md5_hex);
@@ -15,7 +16,7 @@
{
my $i = 0;
- sub GenSSID() {
+ sub GenSSID {
return md5_hex(time,rand,$i++);
}
}
@@ -24,10 +25,6 @@
die new IMPL::NotImplementedException;
}
-sub ValidateSession {
- die new IMPL::NotImplementedException;
-}
-
sub isTrusted {
0;
}
@@ -46,14 +43,18 @@
=head1 NAME
-C Базовыйы класс для пакетов аутентификации.
+C Базовыйы класс для объектов аутентификации.
=head1 DESCRIPTION
C<[Abstract]>
-Аутентификация носит итеративный характер, для чего создается объект аутентификации который
-сохраняет состояние между итерациями.
+Объект аутентификации служет для аутентификации клиента, в случае успеха
+образуется сессия идентифицирующая клиента, которая представлена на стороне
+сервера объектом аутентификации.
+
+Аутентификация носит итеративный характер, объект аутентификации сохраняет
+состояние между итерациями.
Результатом аутентификации является сессия, состояние этой сессии также хранит объект
аутентификации.
@@ -100,34 +101,31 @@
=item C<[get] isTrusted>
-Флаг того, что аутентификация закончена успешно.
+Флаг того, что аутентификация закончена успешно и сессия создана. Данный объект
+может быть создан для аутентификации сессии.
=item C
-Производит аутентификацию пользователя и инициализацию сессии,
-возвращает результат аутентификации, в виде массива ($status,$challenge).
+Производит аутентификацию пользователя, возвращает результат
+аутентификации, в виде массива ($status,$challenge).
-После успешной аутентификации пользователь получает данные C<$challenge>
-для аутентификации сессии.
-
-=item C
-
-Производит аутентификацию сессии, возвращает результат аутентификации,
-в виде массива ($status,$challenge).
+Даже после успешной аутентификации полученные данные C<$challenge> должны быть
+отправлены клиенту для завершения аутентификации на стороне клиента.
=item C<[static] CreateSecData(%args)>
-Создает данные безопасности, на основе параметров. Параметры зависят от пакета аутентификации.
+Создает данные безопасности, на основе параметров. Параметры зависят от пакета
+аутентификации.
=item C<[static] Create(%args)>
-Создает объект аутентификации, на основе параметров. Параметры зависят от пакета аутентификации.
-Внутри вызывает метод C.
+Создает объект аутентификации, на основе параметров. Параметры зависят от
+пакета аутентификации. Внутри вызывает метод C.
=item C<[static] SecDataArgs()>
-Возвращает хеш с описанием параметров для функции C. Ключами являются
-имена параметров, значениями - типы.
+Возвращает хеш с описанием параметров для функции C.
+Ключами являются имена параметров, значениями - типы.
=back
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/Auth/Simple.pm
--- a/Lib/IMPL/Security/Auth/Simple.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Security/Auth/Simple.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,61 +1,69 @@
package IMPL::Security::Auth::Simple;
use strict;
-use parent qw(IMPL::Object IMPL::Security::Auth);
-use Digest::MD5;
+use Digest::MD5 qw(md5_hex);
-use IMPL::Class::Property;
use IMPL::Security::Auth qw(:Const);
-BEGIN {
- private property _passwordImage => prop_all;
- private property _sessionCookie => prop_all;
-}
+use IMPL::Const qw(:prop);
+use IMPL::declare {
+ require => {
+ Exception => 'IMPL::Exception',
+ WrongDataException => '-IMPL::WrongDataException'
+ },
+ base => [
+ 'IMPL::Security::Auth' => undef,
+ 'IMPL::Object' => undef
+ ],
+ props => [
+ _stage => PROP_ALL,
+ _salt => PROP_ALL,
+ _image => PROP_ALL
+ ]
+};
+
+use constant {
+ STAGE_INIT => 1,
+ STAGE_DONE => 2
+};
sub CTOR {
my ($this,$secData) = @_;
- my ($passImg,$cookie) = split /\|/,$secData;
+ my ($stage,$salt,$img) = split /\|/,$secData;
+
+ die WrongDataException->new() unless grep $_ == $stage, (STAGE_INIT, STAGE_DONE);
- $this->_passwordImage($passImg);
- $this->_sessionCookie($cookie);
+ $this->_stage($stage);
+ $this->_salt($salt);
+ $this->_image($img);
+
}
sub secData {
my ($this) = @_;
- if ($this->_sessionCookie) {
- return join ('|',$this->_passwordImage, $this->_sessionCookie );
- } else {
- return $this->_passwordImage;
- }
+ return join ('|',$this->_stage, $this->_salt , $this->_image );
}
sub isTrusted {
my ($this) = @_;
- $this->_sessionCookie ? 1 : 0;
+ $this->_stage == STAGE_DONE ? 1 : 0;
}
sub DoAuth {
my ($this,$challenge) = @_;
-
- if (Digest::MD5::md5_hex($challenge) eq $this->_passwordImage) {
- return (AUTH_SUCCESS,$this->_sessionCookie($this->GenSSID));
- } elsee {
- return (AUTH_FAIL,$this->_sessionCookie(undef));
- }
-}
+
+ my $salt = $this->_salt;
-sub ValidateSession {
- my ($this,$cookie) = @_;
-
- die new IMPL::InvalidOperationException("The context is untrusted") unless $this->_sessionCookie;
-
- if ($cookie eq $this->_sessionCookie) {
- return (AUTH_SUCCESS,undef);
- } else {
- return (AUTH_FAIL,undef);
+ if (md5_hex($salt, $challenge, $salt) eq $this->_image) {
+ if ($this->_stage == STAGE_INIT) {
+ $this->_stage(STAGE_DONE);
+ }
+ return (AUTH_SUCCESS, undef);
+ } elsee {
+ return (AUTH_FAIL, undef);
}
}
@@ -64,11 +72,12 @@
die new IMPL::InvalidArgumentException("The parameter is required",'password') unless $args{password};
- return Digest::MD5::md5_hex($args{password});
+ my $salt = $self->GenSSID();
+ return return join ('|',STAGE_INIT, $salt, md5_hex($salt,$args{password},$salt));
}
sub SecDataArgs {
- password => 'SCALAR'
+ password => 'SCALAR'
}
1;
@@ -87,26 +96,24 @@
=head1 MEMBERS
-=over
-
-=item C
+=head2 C
Создает объект аутентификации, передавая ему данные для инициализации.
-=item C<[get]secData>
+=head2 C<[get]secData>
Возвращает данные безопасности, которые можно использовать для восстановления
состояния объекта.
-=item C<[get]isTrusted>
+=head2 C<[get]isTrusted>
Является ли объект доверенным для аутентификации сессии (тоесть хранит данные
для аутентификации сессии).
-=item C
+=head2 C
Аутентифицирует пользователя. Используется один этап. C<$challenge>
-открытый пароль пользователя.
+открытый пароль пользователя или cookie сессии.
Возвращает C<($status,$challenge)>
@@ -118,28 +125,7 @@
=item C<$challenge>
-В случае успеха возвращает cookie (уникальный номер) сессии
-
-=back
-
-=item C
-
-Проверяет аутентичность сессии. Использует один этап. C<$challenge> cookie
-сессии, полученный при выполнении метода C.
-
-Возвращает C<($status,$challenge)>
-
-=over
-
-=item C<$status>
-
-Результат либо C, либо C
-
-=item C<$challenge>
-
-Всегда C
-
-=back
+В случае успеха возвращает cookie (уникальный номер) сессии, либо C
=back
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/Context.pm
--- a/Lib/IMPL/Security/Context.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Security/Context.pm Mon Oct 08 03:37:37 2012 +0400
@@ -2,88 +2,45 @@
use strict;
use warnings;
-use parent qw(IMPL::Object IMPL::Object::Autofill);
-
-__PACKAGE__->PassThroughArgs;
-
-use IMPL::Class::Property;
-
-require IMPL::Security::Principal;
+use IMPL::require {
+ Principal => 'IMPL::Security::Principal',
+ Role => 'IMPL::Security::Role',
+ AbstractContext => 'IMPL::Security::AbstractContext',
+ Exception => 'IMPL::Exception',
+ ArgumentException => '-IMPL::InvalidArgumentException'
+
+};
-my $current;
-my $nobody;
+use IMPL::declare {
+ base => [
+ 'IMPL::Object' => undef,
+ 'IMPL::Object::Autofill' => undef,
+ 'IMPL::Security::AbstractContext' => undef,
+ ],
+ props => [
+ @{AbstractContext->abstractProps()}
+ ]
+};
-BEGIN {
- public property principal => prop_get;
- public property rolesAssigned => prop_all | prop_list;
- public property auth => prop_all;
- public property authority => prop_all;
-}
+__PACKAGE__->abstractProps([]);
+
+
+my $nobody;
sub CTOR {
my ($this) = @_;
- die new IMPL::InvalidArgumentException("The parameter is required", 'principal') unless $this->principal;
-}
-
-sub Impersonate {
- my ($this,$code) = @_;
-
- my $old = $current;
- $current = $this;
- my $result;
- my $e;
-
- {
- local $@;
- eval {
- $result = $code->();
- };
- $e = $@;
- }
- $current = $old;
- if($e) {
- die $e;
- } else {
- return $result;
- }
-}
-
-sub Apply {
- my ($this) = @_;
-
- $current = $this;
-}
-
-sub isTrusted {
- my ($this) = @_;
-
- if (my $auth = $this->auth) {
- return $auth->isTrusted;
- } else {
- return 0;
- }
+ die ArgumentException->new("The parameter is required", 'principal') unless $this->principal;
}
sub nobody {
my ($self) = @_;
- $nobody = $self->new(principal => IMPL::Security::Principal->nobody) unless $nobody;
+ $nobody = $self->new(principal => Principal->nobody) unless $nobody;
$nobody;
}
-sub current {
- my ($self) = @_;
-
- $current = __PACKAGE__->nobody unless $current;
- $current;
-}
-
-sub Satisfy {
- my ($this,@roles) = @_;
-
- my $roleEffective = new IMPL::Security::Role ( _effective => scalar $this->rolesAssigned );
-
- return $roleEffective->Satisfy(@roles);
+sub isTrusted {
+ return 1;
}
1;
@@ -94,9 +51,10 @@
=head1 NAME
-C - контекст безопасности.
+C - реализация контекста безопасности создаваемого в
+приложении.
-=head1 SINOPSYS
+=head1 SYNOPSIS
=begin code
@@ -108,61 +66,47 @@
}
);
+$context = IMPL::Security::Context->new(
+ principal => $user,
+ assignedRoles => [
+ $backupRole,
+ $controlRole
+ ]
+);
+
+$context->Impersonate(
+ sub {
+
+ # do some authorized operations
+
+ $service->backupData('current.bak');
+ $service->stop();
+ }
+);
+
=end code
=head1 DESCRIPTION
-C<[Autofill]>
+C
-Являет собой контекст безопасности, описывает пользователя и привелегии, так же
-у программы есть текущий контекст безопасности, по умолчанию он C.
+Данная реализация контекста безопасности не привязана ни к источнику данных
+ни к пакету аутентификации и авторизации, ее приложение может создать в любой
+момент, при этом система сама несет ответственность за последствия.
+
+Данный контекст нужен для выполнения системой служебных функций.
=head1 MEMBERS
-=over
-
-=item C
-
-Создает объект и заполняет его свойствами.
-
-=item C<[get] principal>
+см. также C.
-Идентификатор пользователя, владельца контекста.
-
-=item C<[get] rolesAssigned>
-
-Список назначенных (активных) ролей пользователю.
-
-=item C<[get] auth>
-
-Объект асторизации C, использованный при создании текущего контекста.
+=head2 C
-=item C<[static,get] authority>
-
-Источник данных безопасности, породивший данный контекст.
-
-=item C<[get] isTrusted>
-
-Возвращает значение является ли контекст доверенным, тоесть сессия аутетифицирована.
-
-=item C
+Создает объект и заполняет его свойствами. C должен быть обязательно
+указан.
-Делает контекст текущим и выполняет в нем функцию по ссылке C<$code>. По окончании
-выполнения, контекст восстанавливается.
-
-=item C
-
-Заменяет текущий контекст на себя, но до конца действия метода C, если
-таковой был вызван.
-
-=item C<[static,get] nobody>
+=head2 C<[static,get] nobody>
Контекст для неаутентифицированных пользователей, минимум прав.
-=item C<[static,get] current>
-
-Текущий контекст.
-
-=back
-
=cut
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/Principal.pm
--- a/Lib/IMPL/Security/Principal.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Security/Principal.pm Mon Oct 08 03:37:37 2012 +0400
@@ -2,15 +2,22 @@
use strict;
use warnings;
-use parent qw(IMPL::Object IMPL::Object::Autofill);
-use IMPL::Class::Property;
-
-__PACKAGE__->PassThroughArgs;
+use IMPL::Const qw(:prop);
+use IMPL::require {
+ AbstractPrincipal => 'IMPL::Security::AbstractPrincipal'
+};
+use IMPL::declare {
+ base => [
+ 'IMPL::Object' => undef,
+ 'IMPL::Object::Autofill' => '@_',
+ 'IMPL::Security::AbstractPrincipal' => undef
+ ],
+ props => [
+ @{AbstractPrincipal->abstractProps()}
+ ]
+};
-BEGIN {
- public property name => prop_get;
- public property description => prop_all;
-}
+__PACKAGE__->abstractProps([]);
my $nobody;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/Role.pm
--- a/Lib/IMPL/Security/Role.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Security/Role.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,13 +1,22 @@
package IMPL::Security::Role;
+use strict;
-use parent qw(IMPL::Object);
+use IMPL::require {
+ AbstractRole => 'IMPL::Security::AbstractRole'
+};
-use IMPL::Class::Property;
+use IMPL::declare {
+ base => [
+ 'IMPL::Object' => undef,
+ 'IMPL::Security::AbstractRole' => undef
+ ],
+ props => [
+ @{AbstractRole->abstractProps()}
+ ]
+};
-BEGIN {
- public property roleName => prop_get | owner_set;
- public property parentRoles => prop_get | owner_set | prop_list;
-}
+__PACKAGE__->abstractProps([]);
+
sub CTOR {
my ($this,$name,$parentRoles) = @_;
@@ -16,24 +25,6 @@
$this->parentRoles($parentRoles) if $parentRoles;
}
-sub Satisfy {
- my ($this,@roles) = @_;
-
- return 1 unless $this->_FilterRoles( @roles );
- return 0;
-}
-
-sub _FilterRoles {
- my ($this,@roles) = @_;
-
- @roles = grep not (ref $_ ? $this == $_ : $this->roleName eq $_), @roles;
-
- @roles = $_->_FilterRoles(@roles) or return foreach $this->parentRoles ;
-
- return @roles;
-}
-
-
1;
__END__
@@ -42,31 +33,33 @@
=head1 NAME
-C Роль
+C - стандартная реализация роли безопасности.
+
+=head1 SYNOPSIS
+
+=begin code
+
+# create the megarole
+my $role = IMPL::Security::Role->new(megarole => [ $adminRole, $directorRole ] );
+
+#use it in context
+my $context = IMPL::Security::Context->new(
+ principal => $user,
+ assignedRoles => [$user->roles, $megarole]
+);
+
+$context->Impersonate( sub {
+ # do something forbidden
+});
+
+=end code
=head1 DESCRIPTION
-Может включать в себя базовые роли.
-Имеется метод для проверки наличия необходимых ролей в текущей роли.
-
-=head1 MEMBERS
-
-=over
-
-=item C<[get] roleName>
-
-Имя роли, ее идентификатор
+Позволяет создавать объекты ролей без привязки к источникам данных и модулям
+авторизации. Чаще всего используется при реализации каких либо механизмов
+безопасности, где требуется создать временную роль.
-=item C<[get,list] parentRoles>
-
-Список родительских ролей
-
-=item C
+C
-Проверяет наличие ролей указанных ролей из списка @roles_list.
-Допускается использование как самих объектов, так и имен ролей.
-Возвращает 0 в случае неудачи (хотябы одна роль не была удовлетворена), 1 при наличии необходимых ролей.
-
-=back
-
-=cut
+=cut
\ No newline at end of file
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Security/Rule/RoleCheck.pm
--- a/Lib/IMPL/Security/Rule/RoleCheck.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Security/Rule/RoleCheck.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,4 +1,5 @@
package IMPL::Security::Rule::RoleCheck;
+use strict;
require IMPL::Security::Role;
@@ -14,3 +15,4 @@
return ();
}
+1;
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Application.pm
--- a/Lib/IMPL/Web/Application.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Application.pm Mon Oct 08 03:37:37 2012 +0400
@@ -12,7 +12,7 @@
HttpResponse => 'IMPL::Web::HttpResponse',
TFactory => '-IMPL::Object::Factory',
Exception => 'IMPL::Exception',
- InvalidOperationException => 'IMPL::InvalidOperationException',
+ InvalidOperationException => '-IMPL::InvalidOperationException',
Loader => 'IMPL::Code::Loader'
},
base => [
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Application/Action.pm
--- a/Lib/IMPL/Web/Application/Action.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Application/Action.pm Mon Oct 08 03:37:37 2012 +0400
@@ -16,8 +16,6 @@
sub CTOR {
my ($this) = @_;
-
- $this->context({});
}
sub Invoke {
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Application/CustomResource.pm
--- a/Lib/IMPL/Web/Application/CustomResource.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Application/CustomResource.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,7 +1,7 @@
package IMPL::Web::Application::CustomResource;
use strict;
-use IMPL::lang qw(:constants);
+use IMPL::Const qw(:prop);
use IMPL::declare {
require => {
@@ -25,7 +25,12 @@
sub InitContract {
my ($self) = @_;
- $self->_contractInstance( $self->contractFactory->new(resourceFactory => $self ) );
+ $self->_contractInstance(
+ $self->contractFactory->new(
+ resourceFactory => $self,
+ resources => [ $self->GetChildResources() ]
+ )
+ );
}
sub GetChildResources {
@@ -100,14 +105,14 @@
return
$self->SUPER::GetChildResources(),
{
-
- }
- {
-
+ name => 'info',
+ contract => $contractInfo
};
}
=end code
+Метод возвращает список из хешей, которые будут переданы в качестве параметра
+C контракту данного ресурса.
=cut
\ No newline at end of file
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Application/CustomResourceContract.pm
--- a/Lib/IMPL/Web/Application/CustomResourceContract.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Application/CustomResourceContract.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,7 +1,7 @@
package IMPL::Web::Application::CustomResourceContract;
use strict;
-use IMPL::lang qw(:constants);
+use IMPL::Const qw(:prop);
use IMPL::declare {
require => {
NotAllowedException => 'IMPL::Web::NotAllowedException',
@@ -15,7 +15,7 @@
our %RESOURCE_BINDINGS = (
GET => 'HttpGet',
POST => 'HttpPost',
- PUT => 'HttpPut'
+ PUT => 'HttpPut',
DELETE => 'HttpDelete',
HEAD => 'HttpHead'
);
@@ -29,8 +29,8 @@
$this->verbs->{lc($verb)} = OperationContract->new (
binding => sub {
my ($resource,$action) = @_;
-
- if ($resource->can($methodName)) {
+
+ if (eval { $resource->can($methodName) }) {
return $resource->$methodName($action);
} else {
die NotAllowedException->new(allow => join(',', _GetAllowedHttpMethods($resource)));
@@ -44,7 +44,7 @@
sub _HttpOptionsBinding {
my ($resource) = @_;
- my @allow = _GetAllowedHttpMethods;
+ my @allow = _GetAllowedHttpMethods($resource);
retrun HttpResponse->new(
status => '200 OK',
headers => {
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Application/OperationContract.pm
--- a/Lib/IMPL/Web/Application/OperationContract.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Application/OperationContract.pm Mon Oct 08 03:37:37 2012 +0400
@@ -4,9 +4,9 @@
use IMPL::lang qw(:declare);
use IMPL::declare {
require => {
- 'Exception' => 'IMPL::Exception',
- 'ArgumentException' => '-IMPL::ArgumentException',
- 'ResourceBaseClass' => 'IMPL::Web::Application::ResourceBase'
+ Exception => 'IMPL::Exception',
+ ArgumentException => '-IMPL::InvalidArgumentException',
+ ResourceInterface => 'IMPL::Web::Application::ResourceInterface'
},
base => [
'IMPL::Object' => undef,
@@ -22,17 +22,23 @@
sub Invoke {
my ( $this, $resource, $request ) = @_;
- die ArgumentException( resource => 'A valid resource is required' )
- unless eval { $resource->isa(ResourceBaseClass) };
-
+ die ArgumentException->new( resource => 'A valid resource is required' )
+ unless eval { $resource->isa(ResourceInterface) };
+
my $result = eval {
_InvokeDelegate($this->binding, $resource, $request)
};
if (my $e = $@) {
- $result = _InvokeDelegate($this->error, $resource, $request, $e);
+ if ($this->error) {
+ $result = _InvokeDelegate($this->error, $resource, $request, $e) ;
+ } else {
+ die $e;
+ }
+
} else {
- $result = _InvokeDelegate($this->success, $resource, $request, $result);
+ $result = _InvokeDelegate($this->success, $resource, $request, $result)
+ if ($this->success);
}
return $result;
@@ -41,7 +47,7 @@
sub _InvokeDelegate {
my $delegate = shift;
- return $delegete->(@_) if ref $delegate eq 'CODE';
+ return $delegate->(@_) if ref $delegate eq 'CODE';
return $delegate->Invoke(@_) if eval { $delegate->can('Invoke')};
}
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Application/Resource.pm
--- a/Lib/IMPL/Web/Application/Resource.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Application/Resource.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,7 +1,7 @@
package IMPL::Web::Application::Resource;
use strict;
-use IMPL::lang qw(:constants);
+use IMPL::Const qw(:prop);
use IMPL::declare {
require => {
Exception => 'IMPL::Exception',
@@ -36,24 +36,22 @@
$this->id( $args{id} );
$this->contract( $args{contract} );
- # если расположение явно не указано, что обычно делается для корневого
- # ресурса, то оно вычисляется автоматически, либо остается не заданным
- $this->location( $args{location}
- || eval { $this->parent->location->Child( $this->id ) } );
- )
-
+ # если расположение явно не указано, то оно вычисляется автоматически,
+ # либо остается не заданным
+ $this->location( $args{location} || eval { $this->parent->location->Child( $this->id ) } );
}
sub InvokeHttpVerb {
my ( $this, $verb, $action ) = @_;
- my $verb = $this->contract->verbs->{ lc($verb) };
-
+ my $operation = $this->contract->verbs->{ lc($verb) };
+
die NotAllowedException->new(
- allow => join( ',' map( uc, keys %{ $this->contract->verbs } ) ) )
- unless $verb;
+ allow => join( ',', map( uc, keys %{ $this->contract->verbs } ) )
+ )
+ unless $operation;
- return $verb->Invoke( $this, $action );
+ return $operation->Invoke( $this, $action );
}
# это реализация по умолчанию, базируется информации о ресурсах, содержащийся
@@ -61,12 +59,12 @@
sub FetchChildResource {
my ( $this, $childId ) = @_;
- my $info = $this->contract->FindChildResourceInfo($childId);
+ my ($info,$childIdParts) = $this->contract->FindChildResourceInfo($childId);
- die NotFoundException->new() unless $info;
+ die NotFoundException->new($this->location->url,$childId) unless $info;
- my $binding = $this->{binding};
- my $contract = $this->{contract}
+ my $binding = $info->{binding};
+ my $contract = $info->{contract}
or die OperationException->new("Can't fetch a contract for the resource", $childId);
my %args = (
@@ -74,7 +72,7 @@
id => $childId
);
- $args{model} = _InvokeDelegate($binding,$this);
+ $args{model} = _InvokeDelegate($binding,$this,@$childIdParts);
return $contract->CreateResource(%args);
}
@@ -82,7 +80,7 @@
sub _InvokeDelegate {
my $delegate = shift;
- return $delegete->(@_) if ref $delegate eq 'CODE';
+ return $delegate->(@_) if ref $delegate eq 'CODE';
return $delegate->Invoke(@_) if eval { $delegate->can('Invoke')};
}
@@ -145,4 +143,33 @@
собственный класс ресурса, например унаследованный от
C.
+=head1 MEMBERS
+
+=head2 C<[get]contract>
+
+Обязательное свойство для ресурса, ссылается, на контракт, соотсетствующий
+данному ресурсу, используется для выполнения C методов и получения
+дочерних ресурсов.
+
+=head2 C<[get]id>
+
+Обязательное свойство ресурса, идентифицирует его в родительском контейнере,
+для корневого ресурса может иметь произвольное значение.
+
+=head2 C<[get]parent>
+
+Ссылка на родительский ресурс, для корневого ресурса не определена.
+
+=head2 C<[get]model>
+
+Ссылка на объект предметной области, представляемый данным ресурсом. Данное
+свойство не является обязательным и может быть не задано.
+
+=head2 C<[get]location>
+
+Объект типа C или аналогичный описывающий адрес текущего
+ресурса, может быть как явно передан при создании ресурса, так и вычислен
+автоматически (только для ресурсов имеющих родителя). Следует заметить, что
+адрес ресурса не содержит параметров запроса, а только путь.
+
=cut
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Application/ResourceContract.pm
--- a/Lib/IMPL/Web/Application/ResourceContract.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Application/ResourceContract.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,6 +1,6 @@
package IMPL::Web::Application::ResourceContract;
use strict;
-use IMPL::lang qw(:constants);
+use IMPL::Const qw(:prop);
use IMPL::declare {
require => {
'Exception' => 'IMPL::Exception',
@@ -39,7 +39,7 @@
my %nameMap;
- foreach my $res (@$verbs) {
+ foreach my $res (@$resources) {
next unless $res->{contract};
if ( my $name = $res->{name} ) {
$nameMap{$name} = $res;
@@ -213,7 +213,7 @@
package My::Web::Application::ContractMapper;
use strict;
-use IMPL::lang qw(:constants);
+use IMPL::Const qw(:prop);
use IMPL::declare {
require => {
ForbiddenException => 'IMPL::Web::Forbidden'
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Application/ResourceInterface.pm
--- a/Lib/IMPL/Web/Application/ResourceInterface.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Application/ResourceInterface.pm Mon Oct 08 03:37:37 2012 +0400
@@ -29,7 +29,7 @@
=begin code
package MyApp::Web::Resource;
-use IMPL::lang qw(:constants);
+use IMPL::Const qw(:prop);
use IMPL::declare {
require => {
NotAllowedException => 'IMPL::Web::NotAllowedException'
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Exception.pm
--- a/Lib/IMPL/Web/Exception.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Exception.pm Mon Oct 08 03:37:37 2012 +0400
@@ -2,7 +2,7 @@
use strict;
use warnings;
-use IMPL::lang qw(:constants);
+use IMPL::Const qw(:prop);
use IMPL::declare {
base => [
'IMPL::Exception' => '@_'
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Handler/ErrorHandler.pm
--- a/Lib/IMPL/Web/Handler/ErrorHandler.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Handler/ErrorHandler.pm Mon Oct 08 03:37:37 2012 +0400
@@ -49,12 +49,14 @@
error => $err
};
- my $code = 500;
+ my $status = "500 Internal Server Error";
if (eval { $err->isa(WebException) }) {
- ($code) = ($err->status =~ m/^(\d+)/);
+ $status = $err->status;
}
+ my ($code) = ($status =~ m/^(\d+)/);
+
my $doc = $this->loader->document(
$this->errors->{$code} || $this->fallback,
$vars
@@ -63,10 +65,10 @@
my $text = $doc->Render($vars);
$result = HttpResponse->new(
- status => $err->status,
+ status => $status,
type => $this->contentType,
charset => 'utf-8',
- headers => $err->headers,
+ headers => eval{ $err->headers } || {},
body => $text
);
}
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Handler/RestController.pm
--- a/Lib/IMPL/Web/Handler/RestController.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Handler/RestController.pm Mon Oct 08 03:37:37 2012 +0400
@@ -38,11 +38,13 @@
@segments = split(/\//, $pathInfo, $this->trailingSlash ? -1 : 0);
- # remove first segment since it's always empty
- shift @segments;
+ # remove first segment if it is empty
+ shift @segments if @segments && length($segments[0]) == 0;
- my ($obj,$view) = (pop(@segments) =~ m/(.*?)(?:\.(\w+))?$/);
- push @segments, $obj;
+ if(@segments) {
+ my ($obj,$view) = (pop(@segments) =~ m/(.*?)(?:\.(\w+))?$/);
+ push @segments, $obj;
+ }
}
@@ -63,8 +65,6 @@
my $id = shift @segments;
$res = $res->FetchChildResource($id);
-
- die NotFoundException->new($pathInfo,$id) unless $res;
}
$res = $res->InvokeHttpVerb($method,$action);
diff -r 47f77e6409f7 -r 6d8092d8ce1b Lib/IMPL/Web/Handler/SecureCookie.pm
--- a/Lib/IMPL/Web/Handler/SecureCookie.pm Sat Sep 29 02:34:47 2012 +0400
+++ b/Lib/IMPL/Web/Handler/SecureCookie.pm Mon Oct 08 03:37:37 2012 +0400
@@ -1,16 +1,27 @@
-package IMPL::Web::QueryHandler::SecureCookie;
+package IMPL::Web::Handler::SecureCookie;
use strict;
-use parent qw(IMPL::Web::QueryHandler);
+
use Digest::MD5 qw(md5_hex);
-
-use IMPL::Class::Property;
-use IMPL::Security::Auth qw(:Const);
-use IMPL::Security;
-
-BEGIN {
- public property salt => prop_all;
-}
+use IMPL::Const qw(:prop);
+use IMPL::Security::Auth qw(:Const GenSSID);
+use IMPL::declare {
+ require => {
+ SecurityContext => 'IMPL::Security::Context',
+ User => 'IMPL::Security::User',
+ AuthSimple => 'IMPL::Security::Auth::Simple',
+ },
+ base => {
+ 'IMPL::Object' => undef,
+ 'IMPL::Object::Autofill' => '@_',
+ 'IMPL::Object::Serializable' => undef
+ },
+ props => [
+ salt => PROP_RO,
+ manager => PROP_RO,
+ _cookies => PROP_RW
+ ]
+};
sub CTOR {
my ($this) = @_;
@@ -18,67 +29,93 @@
$this->salt('DeadBeef') unless $this->salt;
}
-sub Process {
+sub Invoke {
my ($this,$action,$nextHandler) = @_;
- return undef unless $nextHandler;
+ return unless $nextHandler;
+
+ my $context;
- local $IMPL::Security::authority = $this;
-
- my $method = $action->query->cookie('method') || 'simple';
+
+ my $sid = $action->cookie('sid',qr/(\w+)/);
+ my $cookie = $action->cookie('sdata',qr/(\w+)/);
+ my $sign = $action->cookie('sign',qw/(\w+)/);
- if ($method eq 'simple') {
-
- my $sid = $action->query->cookie('sid');
- my $cookie = $action->query->cookie('sdata');
- my $sign = $action->query->cookie('sign');
+ if (
+ $sid and
+ $cookie and
+ $sign and
+ $sign eq md5_hex(
+ $this->salt,
+ $sid,
+ $cookie,
+ $this->salt
+ )
+ ) {
+ # TODO: add a DefferedProxy to deffer a request to a data source
+ if ( $context = $this->manager->GetSession($sid) ) {
- if (
- $sid and
- $cookie and
- $sign and
- $sign eq md5_hex(
- $this->salt,
- $sid,
- $cookie,
- $this->salt
- )
- ) {
- # TODO: add a DefferedProxy to deffer a request to a data source
- my $context = $action->application->security->sourceSession->find(
- { id => $sid }
- ) or return $nextHandler->();
-
- my ($result,$challenge) = $context->auth->ValidateSession($cookie);
-
- if ($result == AUTH_SUCCESS) {
- $context->authority($this);
- return $context->Impersonate($nextHandler);
- } else {
- return $nextHandler->();
+ if ( eval { $context->auth->isa(AuthSimple) } ) {
+ my ($result,$challenge) = $context->auth->DoAuth($cookie);
+
+ $action->manager->SaveSession($context);
+
+ if ($result == AUTH_FAIL) {
+ $context = undef;
+ }
}
- } else {
- return $nextHandler->();
}
- } else {
- return $nextHandler->();
+
}
+
+ $context = SecurityContext->new(principal => User->nobody, authority => $this);
+
+ my $httpResponse = $context->Impersonate($nextHandler);
+
+ $this->WriteResponse($httpResponse);
+
+}
+
+sub CreateContext {
+ my ($this,$user,$auth,$roles) = @_;
+
+ my $sid = GenSSID();
+ my $cookie = GenSSID();
+
+ $this->_cookies({
+ sid => $sid,
+ sdata => $cookie
+ })
+
+ my $context = $this->$manager->CreateSession(
+ sessionId => $sid,
+ principal => $user,
+ auth => AuthSimple->(password => $cookie),
+ authority => $this,
+ assignedRoles => $roles
+ );
+
+ $context->Apply();
+
+ return $context;
}
sub WriteResponse {
- my ($this,$response,$sid,$cookie,$method) = @_;
+ my ($this,$response) = @_;
+
+ if (my $data $this->_cookies) {
- my $sign = md5_hex(
- $this->salt,
- $sid,
- $cookie,
- $this->salt
- );
-
- $response->setCookie(sid => $sid);
- $response->setCookie(sdata => $cookie);
- $response->setCookie(sign => $sign);
- $response->setCookie(method => $method) if $method;
+ my $sign = md5_hex(
+ $this->salt,
+ $data->{sid},
+ $data->{sdata},
+ $this->salt
+ );
+
+ $response->cookies->{sid} = $data->{sid};
+ $response->cookies->{sdata} = $data->{sdata};
+ $response->cookies->{sign} = $sign;
+ }
}
1;
@@ -89,12 +126,10 @@
=head1 NAME
-C
+C
=head1 DESCRIPTION
-C