Mercurial > pub > Impl
changeset 230:6d8092d8ce1b
*reworked IMPL::Security
*reworked IMPL::Web::Security
*refactoring
line wrap: on
line diff
--- a/.includepath Sat Sep 29 02:34:47 2012 +0400 +++ b/.includepath Mon Oct 08 03:37:37 2012 +0400 @@ -1,5 +1,5 @@ -<?xml version="1.0" encoding="UTF-8"?> -<includepath> - <includepathentry path="${resource_loc:/Impl/Lib}" /> -</includepath> - +<?xml version="1.0" encoding="UTF-8"?> +<includepath> + <includepathentry path="${resource_loc:/Impl/Lib}" /> +</includepath> +
--- /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
--- 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> Класс владелец
--- 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 {
--- 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;
--- 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) = @_;
--- 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); }
--- 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', $_ )
--- 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;
--- /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
--- 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;
--- 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;
--- 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> - Узел в документе который привел к ошибке. Как правило это либо простые узлы, либо узлы, которые не могут присутствоать в данном месте по схеме.
--- 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;
--- 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) );
--- 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];
--- 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;
--- 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};
--- /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<abstract IMPL::Security::Context> - контекст безопасности. + +=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<nobody>. + +=head1 MEMBERS + +=head2 C<[get] principal> + +Идентификатор пользователя, владельца контекста. + +=head2 C<[get] rolesAssigned> + +Список назначенных (активных) ролей пользователю. + +=head2 C<[get] auth> + +Объект асторизации C<IMPL::Security::Auth>, использованный при создании текущего контекста. + +=head2 C<[get] authority> + +Модуль безопасности, породивший данный контекст. Модуль безопасности, отвечающий +за создание контекста безопасности должен реализовывать метод +C<CreateContext($user,$auth,$roles)> + +=head2 C<[get] isTrusted> + +Возвращает значение является ли контекст доверенным, тоесть клиент +аутентифицирован и сессия установлена. Если C<false> значит, что сессия была +начата, однако не установлена до конца. + +=head2 C<Impersonate($code)> + +Делает контекст текущим и выполняет в нем функцию по ссылке C<$code>. По окончании +выполнения, контекст восстанавливается в предыдущий (не зависимо от того, что +с ним происходило во время выполнения C<$code>). + +=head2 C<Apply()> + +Заменяет текущий контекст на себя, но до конца действия метода C<Impersonate>, если +таковой был вызван. + +=cut
--- /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; +
--- /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<IMPL::Security::Role> Роль + +=head1 DESCRIPTION + +Может включать в себя базовые роли. +Имеется метод для проверки наличия необходимых ролей в текущей роли. + +=head1 MEMBERS + +=over + +=item C<[get] roleName> + +Имя роли, ее идентификатор + +=item C<[get,list] parentRoles> + +Список родительских ролей + +=item C<Satisfy(@roles_list)> + +Проверяет наличие ролей указанных ролей из списка @roles_list. +Допускается использование как самих объектов, так и имен ролей. +Возвращает 0 в случае неудачи (хотябы одна роль не была удовлетворена), 1 при наличии необходимых ролей. + +=back + +=cut
--- 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<IMPL::Security::Auth> Базовыйы класс для пакетов аутентификации. +C<IMPL::Security::Auth> Базовыйы класс для объектов аутентификации. =head1 DESCRIPTION C<[Abstract]> -Аутентификация носит итеративный характер, для чего создается объект аутентификации который -сохраняет состояние между итерациями. +Объект аутентификации служет для аутентификации клиента, в случае успеха +образуется сессия идентифицирующая клиента, которая представлена на стороне +сервера объектом аутентификации. + +Аутентификация носит итеративный характер, объект аутентификации сохраняет +состояние между итерациями. Результатом аутентификации является сессия, состояние этой сессии также хранит объект аутентификации. @@ -100,34 +101,31 @@ =item C<[get] isTrusted> -Флаг того, что аутентификация закончена успешно. +Флаг того, что аутентификация закончена успешно и сессия создана. Данный объект +может быть создан для аутентификации сессии. =item C<DoAuth($challenge)> -Производит аутентификацию пользователя и инициализацию сессии, -возвращает результат аутентификации, в виде массива ($status,$challenge). +Производит аутентификацию пользователя, возвращает результат +аутентификации, в виде массива ($status,$challenge). -После успешной аутентификации пользователь получает данные C<$challenge> -для аутентификации сессии. - -=item C<ValidateSession($challenge)> - -Производит аутентификацию сессии, возвращает результат аутентификации, -в виде массива ($status,$challenge). +Даже после успешной аутентификации полученные данные C<$challenge> должны быть +отправлены клиенту для завершения аутентификации на стороне клиента. =item C<[static] CreateSecData(%args)> -Создает данные безопасности, на основе параметров. Параметры зависят от пакета аутентификации. +Создает данные безопасности, на основе параметров. Параметры зависят от пакета +аутентификации. =item C<[static] Create(%args)> -Создает объект аутентификации, на основе параметров. Параметры зависят от пакета аутентификации. -Внутри вызывает метод C<CreateSecData(%args)>. +Создает объект аутентификации, на основе параметров. Параметры зависят от +пакета аутентификации. Внутри вызывает метод C<CreateSecData(%args)>. =item C<[static] SecDataArgs()> -Возвращает хеш с описанием параметров для функции C<CreateSecData>. Ключами являются -имена параметров, значениями - типы. +Возвращает хеш с описанием параметров для функции C<CreateSecData>. +Ключами являются имена параметров, значениями - типы. =back
--- 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<CTOR($secData)> +=head2 C<CTOR($secData)> Создает объект аутентификации, передавая ему данные для инициализации. -=item C<[get]secData> +=head2 C<[get]secData> Возвращает данные безопасности, которые можно использовать для восстановления состояния объекта. -=item C<[get]isTrusted> +=head2 C<[get]isTrusted> Является ли объект доверенным для аутентификации сессии (тоесть хранит данные для аутентификации сессии). -=item C<DoAuth($challenge)> +=head2 C<DoAuth($challenge)> Аутентифицирует пользователя. Используется один этап. C<$challenge> -открытый пароль пользователя. +открытый пароль пользователя или cookie сессии. Возвращает C<($status,$challenge)> @@ -118,28 +125,7 @@ =item C<$challenge> -В случае успеха возвращает cookie (уникальный номер) сессии - -=back - -=item C<ValidateSession($challenge)> - -Проверяет аутентичность сессии. Использует один этап. C<$challenge> cookie -сессии, полученный при выполнении метода C<DoAuth>. - -Возвращает C<($status,$challenge)> - -=over - -=item C<$status> - -Результат либо C<AUTH_SUCCESS>, либо C<AUTH_FAIL> - -=item C<$challenge> - -Всегда C<undef> - -=back +В случае успеха возвращает cookie (уникальный номер) сессии, либо C<undef> =back
--- 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<IMPL::Security::Context> - контекст безопасности. +C<IMPL::Security::Context> - реализация контекста безопасности создаваемого в +приложении. -=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<autofill> -Являет собой контекст безопасности, описывает пользователя и привелегии, так же -у программы есть текущий контекст безопасности, по умолчанию он C<nobody>. +Данная реализация контекста безопасности не привязана ни к источнику данных +ни к пакету аутентификации и авторизации, ее приложение может создать в любой +момент, при этом система сама несет ответственность за последствия. + +Данный контекст нужен для выполнения системой служебных функций. =head1 MEMBERS -=over - -=item C<CTOR(%props)> - -Создает объект и заполняет его свойствами. - -=item C<[get] principal> +см. также C<IMPL::Security::AbstractContext>. -Идентификатор пользователя, владельца контекста. - -=item C<[get] rolesAssigned> - -Список назначенных (активных) ролей пользователю. - -=item C<[get] auth> - -Объект асторизации C<IMPL::Security::Auth>, использованный при создании текущего контекста. +=head2 C<CTOR(%props)> -=item C<[static,get] authority> - -Источник данных безопасности, породивший данный контекст. - -=item C<[get] isTrusted> - -Возвращает значение является ли контекст доверенным, тоесть сессия аутетифицирована. - -=item C<Impersonate($code)> +Создает объект и заполняет его свойствами. C<principal> должен быть обязательно +указан. -Делает контекст текущим и выполняет в нем функцию по ссылке C<$code>. По окончании -выполнения, контекст восстанавливается. - -=item C<Apply()> - -Заменяет текущий контекст на себя, но до конца действия метода C<Impersonate>, если -таковой был вызван. - -=item C<[static,get] nobody> +=head2 C<[static,get] nobody> Контекст для неаутентифицированных пользователей, минимум прав. -=item C<[static,get] current> - -Текущий контекст. - -=back - =cut
--- 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;
--- 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<IMPL::Security::Role> Роль +C<IMPL::Security::Role> - стандартная реализация роли безопасности. + +=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<Satisfy(@roles_list)> +C<IMPL::Security::AbstractRole> -Проверяет наличие ролей указанных ролей из списка @roles_list. -Допускается использование как самих объектов, так и имен ролей. -Возвращает 0 в случае неудачи (хотябы одна роль не была удовлетворена), 1 при наличии необходимых ролей. - -=back - -=cut +=cut \ No newline at end of file
--- 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;
--- 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 => [
--- 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 {
--- 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<resources> контракту данного ресурса. =cut \ No newline at end of file
--- 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 => {
--- 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')}; }
--- 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<IMPL::Web::Application::CustomResource>. +=head1 MEMBERS + +=head2 C<[get]contract> + +Обязательное свойство для ресурса, ссылается, на контракт, соотсетствующий +данному ресурсу, используется для выполнения C<HTTP> методов и получения +дочерних ресурсов. + +=head2 C<[get]id> + +Обязательное свойство ресурса, идентифицирует его в родительском контейнере, +для корневого ресурса может иметь произвольное значение. + +=head2 C<[get]parent> + +Ссылка на родительский ресурс, для корневого ресурса не определена. + +=head2 C<[get]model> + +Ссылка на объект предметной области, представляемый данным ресурсом. Данное +свойство не является обязательным и может быть не задано. + +=head2 C<[get]location> + +Объект типа C<IMPL::Web::AutoLocator> или аналогичный описывающий адрес текущего +ресурса, может быть как явно передан при создании ресурса, так и вычислен +автоматически (только для ресурсов имеющих родителя). Следует заметить, что +адрес ресурса не содержит параметров запроса, а только путь. + =cut
--- 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'
--- 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'
--- 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' => '@_'
--- 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 ); }
--- 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);
--- 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<IMPL::Web::QueryHandler::SecureCookie> +C<IMPL::Web::Handler::SecureCookie> =head1 DESCRIPTION -C<use parent qw(IMPL::Web::QueryHandler)> - Возобновляет сессию пользователя на основе информации переданной через Cookie. Использует механизм подписи информации для проверки верности входных данных перед @@ -102,6 +137,8 @@ Данный обработчик возвращает результат выполнения следдующего обработчика. + + =head1 MEMBERS =over
--- a/Lib/IMPL/Web/HttpResponse.pm Sat Sep 29 02:34:47 2012 +0400 +++ b/Lib/IMPL/Web/HttpResponse.pm Mon Oct 08 03:37:37 2012 +0400 @@ -48,7 +48,7 @@ binmode $out, ":encoding($charset)"; } - $q->header(\%headers); + print $out $q->header(\%headers); if(my $body = $this->body) { if(ref $body eq 'CODE') { @@ -64,6 +64,25 @@ return UNIVERSAL::isa($_[1], 'CGI::Cookie') ? $_[1] : CGI::Cookie->new(-name => $_[0], -value => $_[1] ); } +sub InternalError { + my ($self,%args) = @_; + + $args{status} ||= '500 Internal Server Error'; + + return $self->new(%args); +} + +sub Redirect { + my ($self,%args) = @_; + + return $self->new( + status => $args{status} || '303 See other', + headers => { + location => $args{location} + } + ); +} + 1; __END__
--- a/Lib/IMPL/Web/NotAllowedException.pm Sat Sep 29 02:34:47 2012 +0400 +++ b/Lib/IMPL/Web/NotAllowedException.pm Mon Oct 08 03:37:37 2012 +0400 @@ -1,7 +1,7 @@ package IMPL::Web::NotAllowedException; use strict; -use IMPL::lang qw(:constants); +use IMPL::Const qw(:prop); use IMPL::declare { base => [ 'IMPL::Web::Exception' => sub { @@ -12,6 +12,7 @@ }; sub CTOR { + my $this = shift; my %args = @_; $this->headers({
--- a/Lib/IMPL/Web/Security.pm Sat Sep 29 02:34:47 2012 +0400 +++ b/Lib/IMPL/Web/Security.pm Mon Oct 08 03:37:37 2012 +0400 @@ -1,57 +1,63 @@ package IMPL::Web::Security; use strict; -use parent qw(IMPL::Object IMPL::Security IMPL::Object::Autofill); -require IMPL::Web::Security::Session; - -use IMPL::Class::Property; use IMPL::Security::Auth qw(:Const); - -__PACKAGE__->PassThroughArgs; - -BEGIN { - public property sourceUser => prop_all; - public property sourceSession => prop_all; -} - -sub CTOR { - my ($this) = @_; - - die new IMPL::InvalidArgumentException("An argument is required",'sourceUser') unless $this->sourceUser; - die new IMPL::InvalidArgumentException("An argument is required",'sourceSession') unless $this->sourceSession; -} +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + NotImplementedException => '-IMPL::NotImplementedException', + SecurityContext => 'IMPL::Security::AbstractContext' + }, +}; sub AuthUser { my ($this,$name,$package,$challenge) = @_; - my $user = $this->sourceUser->find({name => $name}) or return { status => AUTH_FAIL, answer => "Can't find a user '$name'" }; + my $user = $this->FindUserByName($name) + or return { status => AUTH_FAIL, answer => "Can't find a user '$name'" }; - my $auth; - if ( my $secData = $user->secData($package) ) { + my $auth; + if ( my $secData = $user->GetSecData($package) ) { $auth = $package->new($secData); } else { - die new IMPL::SecurityException("Authentication failed","A sec data for the $package isn't found"); + return { + status => AUTH_FAIL, + user => $user + }; } my ($status,$answer) = $auth->DoAuth($challenge); + if ($status != AUTH_FAIL) { + SecurityContext->current->authority->CreateContext( + $user, + $auth, + [$user->roles], + $answer, + $this + ); + } + return { status => $status, - answer => $answer, - context => $this->MakeContext( $user, [$user->roles], $auth ) - } + user => $user + }; } -sub MakeContext { - my ($this,$principal,$roles,$auth) = @_; - - return $this->sourceSession->create( - { - principal => $principal, - rolesAssigned => $roles, - auth => $auth - } - ); +sub FindUserByName { + die NotImplementedException->new(); +} + +sub CreateSession { + die NotImplementedException->new(); +} + +sub GetSession { + die NotImplementedException->new(); +} + +sub SaveSession { + die NotImplementedException->new(); } 1; @@ -88,11 +94,11 @@ сохраняет свое состояние. Поэтому при каждом обращении сервер восстанавливает контекст безопасности. -C<IMPL::Web::Session> Объект обеспечивающий сохранение состояния в рамках одной сессии +C<IMPL::Web::Security::Session> Объект обеспечивающий сохранение состояния в рамках одной сессии пользователя. Кроме контекста безопасности хранит дополнительние данные, которые необходимо сохранить между обработкой запросов. -C<IMPL::Web::User> Объект, устанавливающий связь между идентификатором пользователя +C<IMPL::Web::Security::User> Объект, устанавливающий связь между идентификатором пользователя C<IMPL::Security::Principal>, его ролями и данными безопасности для создания объектов аутентификации C<IMPL::Security::Auth>.
--- a/Lib/IMPL/Web/Security/Session.pm Sat Sep 29 02:34:47 2012 +0400 +++ b/Lib/IMPL/Web/Security/Session.pm Mon Oct 08 03:37:37 2012 +0400 @@ -1,14 +1,15 @@ package IMPL::Web::Security::Session; use strict; -use parent qw(IMPL::Security::Context); - -use IMPL::Class::Property; +use parent qw(); -__PACKAGE__->PassThroughArgs; +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Security::AbstractContext' => '@_' + ] +}; -BEGIN { - public property id => prop_all | owner_set; -} +push @{__PACKAGE__->abstractProps}, sessionId => PROP_RW; 1; @@ -48,7 +49,7 @@ =over -=item C<[get] id> +=item C<[get] sessionId> Идентификатор сессии
--- a/Lib/IMPL/Web/Security/User.pm Sat Sep 29 02:34:47 2012 +0400 +++ b/Lib/IMPL/Web/Security/User.pm Mon Oct 08 03:37:37 2012 +0400 @@ -1,5 +1,25 @@ package IMPL::Web::Security::User; +use strict; -use parent qw(IMPL::Security::Principal); +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + NotImplementedException => '-IMPL::NotImplementedException' + }, + base => [ + 'IMPL::Security::AbstractPrincipal' => undef + ] +}; + +push @{__PACKAGE__->abstractProps}, roles => PROP_RW | PROP_LIST; + +sub GetSecData { + die NotImplementedException->new(); +} + +sub SetSecData { + die NotImplementedException->new(); +} 1;
--- a/Lib/IMPL/declare.pm Sat Sep 29 02:34:47 2012 +0400 +++ b/Lib/IMPL/declare.pm Mon Oct 08 03:37:37 2012 +0400 @@ -4,6 +4,7 @@ use Scalar::Util qw(set_prototype); use Carp qw(carp); use IMPL::Class::PropertyInfo(); +use IMPL::Const qw(:access); sub import { my ( $self, $args ) = @_; @@ -52,6 +53,9 @@ $ctor{$class} = $mapper; } } + + *{"${caller}::CTOR"} = \%ctor; + *{"${caller}::ISA"} = \@isa; my $props = $args->{props} || []; @@ -75,16 +79,13 @@ Mutators => $spec, Class => $caller, Access => $prop =~ /^_/ - ? IMPL::Class::MemberInfo::MOD_PRIVATE - : IMPL::Class::MemberInfo::MOD_PUBLIC + ? ACCESS_PRIVATE + : ACCESS_PUBLIC } ); $propInfo->Implement(); } } - - *{"${caller}::CTOR"} = \%ctor; - *{"${caller}::ISA"} = \@isa; } sub _require {
--- a/Lib/IMPL/lang.pm Sat Sep 29 02:34:47 2012 +0400 +++ b/Lib/IMPL/lang.pm Mon Oct 08 03:37:37 2012 +0400 @@ -16,18 +16,6 @@ &clone ) ], - constants => [ - qw( - &ACCESS_PUBLIC - &ACCESS_PROTECTED - &ACCESS_PRIVATE - &PROP_GET - &PROP_SET - &PROP_OWNERSET - &PROP_LIST - &PROP_ALL - ) - ], declare => [ qw( @@ -46,6 +34,8 @@ &PROP_OWNERSET &PROP_LIST &PROP_ALL + &PROP_RO + &PROP_RW ) ], compare => [ @@ -69,16 +59,7 @@ 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 -}; +use IMPL::Const qw(:all); sub is($$) { eval { $_[0]->isa( $_[1] ) };
--- a/Lib/IMPL/require.pm Sat Sep 29 02:34:47 2012 +0400 +++ b/Lib/IMPL/require.pm Mon Oct 08 03:37:37 2012 +0400 @@ -1,6 +1,7 @@ package IMPL::require; use Scalar::Util qw(set_prototype); use strict; +require IMPL::Code::Loader; sub import { my ($self, $aliases) = @_; @@ -14,8 +15,7 @@ no strict 'refs'; while( my ($alias, $class) = each %$aliases ) { - (my $file = $class) =~ s/::|'/\//g; - require "$file.pm"; + _require($class); *{"${caller}::$alias"} = set_prototype(sub { $class @@ -23,6 +23,16 @@ } } +sub _require { + my ($class) = @_; + + if ( not $class =~ s/^-// ) { + ( my $file = $class ) =~ s/::|'/\//g; + require "$file.pm"; + } + $class; +} + 1; __END__