# HG changeset patch # User cin # Date 1392308242 -14400 # Node ID 2287c72f303aa662532153310a612f0aaabdbf75 # Parent de1f875e8875794a1dbfdd14526868f39d0d786a code cleanup diff -r de1f875e8875 -r 2287c72f303a Lib/IMPL/DOM/Transform/ObjectToDOM.pm --- a/Lib/IMPL/DOM/Transform/ObjectToDOM.pm Wed Feb 12 18:02:03 2014 +0400 +++ b/Lib/IMPL/DOM/Transform/ObjectToDOM.pm Thu Feb 13 20:17:22 2014 +0400 @@ -128,7 +128,7 @@ my ($this,$data) = @_; return $this->StoreObject($this->currentNode,$data) - if !$this->currentNode->schema->isa(ComplexNode); + if !$this->currentNode->schemaType->isa(ComplexNode); if ( ref $data and eval { $data->can('GetMeta') } ) { my %props = map { diff -r de1f875e8875 -r 2287c72f303a Lib/IMPL/Web/Application/Action.pm --- a/Lib/IMPL/Web/Application/Action.pm Wed Feb 12 18:02:03 2014 +0400 +++ b/Lib/IMPL/Web/Application/Action.pm Thu Feb 13 20:17:22 2014 +0400 @@ -10,7 +10,8 @@ use IMPL::Web::CGIWrapper(); use IMPL::declare { require => { - Disposable => '-IMPL::Object::Disposable' + Disposable => '-IMPL::Object::Disposable', + HttpResponse => 'IMPL::Web::HttpResponse' }, base => [ 'IMPL::Object' => undef, @@ -154,6 +155,13 @@ return $path ? URI->new_abs($path,$this->applicationUrl) : $this->applicationUrl; } +sub Redirect { + my ($this,$path) = @_; + return HttpResponse->Redirect( + location => $this->CreateFullUrl($path) + ); +} + sub _launder { my ($this,$value,$rx) = @_; diff -r de1f875e8875 -r 2287c72f303a Lib/IMPL/Web/Application/ControllerUnit.pm --- a/Lib/IMPL/Web/Application/ControllerUnit.pm Wed Feb 12 18:02:03 2014 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,467 +0,0 @@ -use strict; -package IMPL::Web::Application::ControllerUnit; -use parent qw(IMPL::Object); - -use IMPL::Class::Property; -use IMPL::DOM::Transform::PostToDOM; -use IMPL::DOM::Schema; -use Class::Inspector; -use File::Spec; -use Sub::Name; - -use constant { - CONTROLLER_METHODS => 'controller_methods', - STATE_CORRECT => 'correct', - STATE_NEW => 'new', - STATE_INVALID => 'invalid', - TTYPE_FORM => 'form', - TTYPE_TRANS => 'tran' -}; - -BEGIN { - public property action => prop_get | owner_set; - public property application => prop_get | owner_set; - public property query => prop_get | owner_set; - public property response => prop_get | owner_set; - public property formData => prop_get | owner_set; - public property formSchema => prop_get | owner_set; - public property formErrors => prop_get | owner_set; -} - -my %publicProps = map {$_->Name , 1} __PACKAGE__->GetMeta(typeof IMPL::Class::PropertyInfo); - -__PACKAGE__->class_data(CONTROLLER_METHODS,{}); - -our @schemaInc; - -sub CTOR { - my ($this,$action,$args) = @_; - - $this->action($action); - $this->application($action->application); - $this->query($action->query); - $this->response($action->response); - - $this->$_($args->{$_}) foreach qw(formData formSchema formErrors); -} - -sub unitNamespace() { - "" -} - -sub transactions { - my ($self,%methods) = @_; - - while (my ($method,$info) = each %methods) { - if ($info and ref $info ne 'HASH') { - warn "Bad transaction $method description"; - $info = {}; - } - - $info->{wrapper} = 'TransactionWrapper'; - $info->{method} ||= $method; - $info->{context}{transactionType} = TTYPE_TRANS; - $self->class_data(CONTROLLER_METHODS)->{$method} = $info; - } -} - -sub forms { - my ($self,%forms) = @_; - - while ( my ($method,$info) = each %forms ) { - die new IMPL::Exception("A method doesn't exists in the controller",$self,$method) unless $self->can($method); - if ( not ref $info ) { - $self->class_data(CONTROLLER_METHODS)->{$method} = { - wrapper => 'FormWrapper', - schema => $info, - method => $method, - context => { transactionType => TTYPE_FORM } - }; - } elsif (ref $info eq 'HASH') { - $info->{wrapper} = 'FormWrapper'; - $info->{method} ||= $method; - $info->{context}{transactionType} = TTYPE_FORM; - - $self->class_data(CONTROLLER_METHODS)->{$method} = $info; - } else { - die new IMPL::Exception("Unsupported method information",$self,$method); - } - } -} - -sub InvokeAction { - my ($self,$method,$action) = @_; - - if (my $methodInfo = $self->class_data(CONTROLLER_METHODS)->{$method}) { - if (my $ctx = $methodInfo->{context}) { - $action->context->{$_} = $ctx->{$_} foreach keys %$ctx; - } - if (my $wrapper = $methodInfo->{wrapper}) { - return $self->$wrapper($method,$action,$methodInfo); - } else { - return $self->TransactionWrapper($method,$action,$methodInfo); - } - } else { - die new IMPL::InvalidOperationException("Invalid method call",$self,$method); - } -} - -sub MakeParams { - my ($this,$methodInfo) = @_; - - my $params; - if ($params = $methodInfo->{parameters} and ref $params eq 'ARRAY') { - return map $this->ResolveParam($_,$methodInfo->{inflate}{$_}), @$params; - } - return(); -} - -sub ResolveParam { - my ($this,$param,$inflate) = @_; - - if ( $param =~ /^::(\w+)$/ and $publicProps{$1}) { - return $this->$1(); - } else { - my $value; - if ( my $rx = $inflate->{rx} ) { - $value = $this->action->param($param,$rx); - } else { - $value = $this->query->param($param); - } - - if (my $method = $inflate->{method}) { - $value = $this->$method($value); - } - return $value; - } -} - -sub TransactionWrapper { - my ($self,$method,$action,$methodInfo) = @_; - - my $unit = $self->new($action); - my $handler = $methodInfo->{method}; - return $unit->$handler($unit->MakeParams($methodInfo)); -} - -sub FormWrapper { - my ($self,$method,$action,$methodInfo) = @_; - - my $schema = $methodInfo->{schema} ? $self->loadSchema($methodInfo->{schema}) : $self->unitSchema; - - my $process = $action->query->param('process') || 0; - my $form = $methodInfo->{form} - || $action->query->param('form') - || $method; - - my %result; - - my $transform = IMPL::DOM::Transform::PostToDOM->new( - undef, - $schema, - $form - ); - - my $handler = $methodInfo->{method}; - - $result{formName} = $form; - $result{formSchema} = $schema; - - if ($process) { - $result{formData} = $transform->Transform($action->query); - $result{formErrors} = $transform->Errors->as_list; - if ($transform->Errors->Count) { - $result{state} = STATE_INVALID; - } else { - $result{state} = STATE_CORRECT; - my $unit = $self->new($action,\%result); - - eval { - $result{result} = $unit->$handler($unit->MakeParams($methodInfo)); - }; - if (my $err = $@) { - $result{state} = STATE_INVALID; - if (eval { $err->isa(typeof IMPL::WrongDataException) } ) { - $result{formErrors} = $err->Args; - } else { - die $err; - } - } - } - } else { - if (my $initMethod = $methodInfo->{init}) { - my $unit = $self->new($action,\%result); - $result{formData} = $transform->Transform( $unit->$initMethod($unit->MakeParams($methodInfo)) ); - } else { - $result{formData} = $transform->Transform($action->query); - } - - # ignore errors for new forms - #$result{formErrors} = $transform->Errors->as_list; - $result{state} = STATE_NEW; - } - - return \%result; -} - -sub loadSchema { - my ($self,$name) = @_; - - foreach my $path (map File::Spec->catfile($_,$name) ,@schemaInc) { - return IMPL::DOM::Schema->LoadSchema($path) if -f $path; - } - - die new IMPL::Exception("A schema isn't found", $name); -} - -sub unitSchema { - my ($self) = @_; - - my $class = ref $self || $self; - - my @parts = split(/:+/, $class); - - my $file = pop @parts; - $file = "${file}.schema.xml"; - - foreach my $inc ( @schemaInc ) { - my $path = File::Spec->catfile($inc,@parts,$file); - - return IMPL::DOM::Schema->LoadSchema($path) if -f $path; - } - - return undef; -} - -sub discover { - my ($this) = @_; - - my $methods = $this->class_data(CONTROLLER_METHODS); - - my $namespace = $this->unitNamespace; - (my $module = typeof($this)) =~ s/^$namespace//; - - my %smd = ( - module => [grep $_, split /::/, $module ], - ); - - while (my ($method,$info) = each %$methods) { - my %methodInfo = ( - name => $method - ); - $methodInfo{parameters} = [ grep /^[^\:]/, @{ $info->{parameters} } ] if ref $info->{parameters} eq 'ARRAY'; - push @{$smd{methods}},\%methodInfo; - } - return \%smd; -} - -__PACKAGE__->transactions( - discover => undef -); - -1; - -__END__ - -=pod - -=head1 NAME - -C - базовый класс для обработчика транзакций в модели контроллера. - -=head1 DESCRIPTION - -Классы, наследуемые от данного класса называется пакетом транзакций. Часть методов в таком классе -объявляются как транзакции при помощи методов C, C
. - -Перед выполнением транзакции создается экземпляр объекта, в рамках которого будет выполнена транзакция. -Для этого вызывается метод C, который создает/восстанавливает контекст -транзакции. - -Транзакции на данный момент делятся на простые и формы. Различные типы транзакций выполняются при помощи -различных оберток (C и C). Каждая обертка отвечает за конструирование -экземпляра объекта и вызов метода для выполнения транзакции, а также за возврат результата выполнения. - -=head2 Простые транзакции - -Простые транзакции получаю только запрос, без предварительной обработки, и возвращенный результат напрямую -передается пользователю. - -=head2 Формы - -При использовании форм запрос предварительно обрабатывается, для получения DOM документа с данными формы. -Для постороенния DOM документа используется схема. При этом становятся доступны дополнительные свойства -C, C, C. - -Результат выполнения транзакции не возвращается наверх напрямую, а включается в структуру, которая -выглядит следующим образом - -=begin code - -{ - state => '{ new | correct | invalid }', - result => $transactionResult, - formData => $formDOM, - formSchema => $formSchema, - formErrors => @errors -} - -=end code - -=over - -=item C - -Состояние верификации формы. - -=over - -=item C - -Первоначальное содержимое формы, оно может быть некорректным, но это нормально. -В данном состоянии транзакция обычно не выполняется. - -=item C - -Данные формы корректны, транзакция выполнена, и ее результат доступен через поле C - -=item C - -Содержимое формы не прошло верификацию, ошибки доступны через поле C. Транзакция -не выполнялась. - -=back - -=item C - -Результат выполнения транзакции, если конечно таковая выполнялась. - -=item C - -ДОМ документ с данными формами. Документ существует всегда, не зависимо от его корректности, -может быть использован для построения формы, уже заполненную параметрами. - -=item C - -Схема данных формы, может использоваться для построения динамических форм. - -=item C - -Ссылка на массив с ошибками при проверки формы. - -=back - -=head1 MEMBERS - -=over - -=item C<[get] application> - -Объект приложения, которое обрабатывает запрос. - -=item C<[get] query> - -Текущий запрос. - -=item C<[get] response> - -Текущий ответ. - -=item C<[get] formData> - -C документ с данныим, если данный запрос является формой. - -=item C<[get] formSchema> - -C документ со схемой формы данного запроса. - -=item C<[get] formErrors> - -Ошибки верификации данных, если таковые были. Обычно при наличии ошибок в форме, транзакция -не выполняется, а эти ошибки передаются в ответ. - -=item C - -Конструирует контекст выполнения транзакции, может быть переопределен для конструирования контекста по -своим правилам. - -=item C - -Обертка для конструирования простых транзакций, может быть переопределен для конструирования контекста по -своим правилам. - -=item C - -Обертка для конструирования форм, может быть переопределен для конструирования контекста по -своим правилам. - -=item C - -Метод, опубликованный для вызова контроллером, возвращает описание методов в формате C. - -=begin code - -# SMD structure -{ - module => ['Foo','Bar'], - methods => [ - { - name => 'search', - parameters => ['text','limit'] #optional - } - ] -} - -=end code - -=back - -=head1 EXAMPLE - -=begin code - -package MyBooksUnit; -use strict; -use parent qw(IMPL::Web::Application::ControllerUnit); - -__PACKAGE__->PassThroughArgs; - -sub unitDataClass { 'My::Books' } - -__PACKAGE__->transactions( - find => { - parameters => [qw(author)] - }, - info => { - parameters => [qw(id)] - } -); -__PACKAGE__->forms( - create => 'books.create.xml' -); - -sub find { - my ($this,$author) = @_; - - return $this->ds->find({author => $author}); -} - -sub info { - my ($this,$id) = @_; - - return $this->ds->find({id => $id}); -} - -sub create { - my ($this) = @_; - - my %book = map { - $_->nodeName, $_->nodeValue - } $this->formData->selectNodes([qw(author_id title year ISBN)]); - - return $this->ds->create(\%book); -} - -=end code - -=cut diff -r de1f875e8875 -r 2287c72f303a Lib/IMPL/Web/Application/CustomResource.pm --- a/Lib/IMPL/Web/Application/CustomResource.pm Wed Feb 12 18:02:03 2014 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,291 +0,0 @@ -package IMPL::Web::Application::CustomResource; -use strict; - -use IMPL::Const qw(:prop); -use IMPL::lang qw(:hash :base); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - OperationException => '-IMPL::InvalidOperationException', - NotFoundException => 'IMPL::Web::NotFoundException', - HttpResponse => 'IMPL::Web::HttpResponse', - Loader => 'IMPL::Code::Loader' - }, - base => [ 'IMPL::Web::Application::ResourceBase' => '@_' ], - props => [ - accessCheck => PROP_RW, - resources => PROP_RO, - verbs => PROP_RO, - namedResources => PROP_RO, - regexResources => PROP_RO - ] -}; - -use constant { CustomResource => __PACKAGE__ }; - -our %RESOURCE_BINDINGS = ( - GET => 'HttpGet', - POST => 'HttpPost', - PUT => 'HttpPut', - DELETE => 'HttpDelete', - HEAD => 'HttpHead', - OPTIONS => 'HttpOptions', - TRACE => 'HttpTrace' -); - -sub CTOR { - my ( $this, %args ) = @_; - - $this->verbs( $args{verbs} || {} ); - $this->resources( $args{resources} || [] ); - - $this->accessCheck( $args{accessCheck} ) - if $args{accessCheck}; - - while ( my ( $verb, $methodName ) = each %RESOURCE_BINDINGS ) { - if ( my $method = $this->can($methodName) ) { - $this->verbs->{ lc($verb) } ||= $method; - } - } -} - -sub FindChildResourceInfo { - my ( $this, $name ) = @_; - - $this->PrepareResourcesCache() - unless $this->namedResources; - - if ( my $info = $this->namedResources->{$name} ) { - return $info, [$name]; - } - else { - foreach my $info ( @{ $this->regexResources } ) { - my $rx = $info->{match}; - if ( my @childId = $name =~ m/$rx/ ) { - return $info, \@childId; - } - } - } - - return; -} - -# это реализация по умолчанию, базируется информации о ресурсах, содержащийся -# в контракте. -sub FetchChildResource { - my ( $this, $childId ) = @_; - - $this->AccessCheck('FETCH'); - - my ( $info, $childIdParts ) = $this->FindChildResourceInfo($childId); - - die NotFoundException->new( $this->location->url, $childId ) unless $info; - - my %args; - - my $binding = $info->{binding}; - my $contract = $info->{contract}; - if ( ref($binding) eq 'HASH' ) { - $args{$_} = _InvokeDelegate( $binding->{$_}, $this, @$childIdParts ) - foreach keys %$binding; - } - else { - $args{model} = _InvokeDelegate( $binding, $this, @$childIdParts ); - } - - # support for dynamic contracts - if ( ref $contract eq 'CODE' || eval { $contract->can('Invoke') } ) { - $contract = _InvokeDelegate( $contract, $this, $args{model} ); - } - - die OperationException->new( "Can't fetch a contract for the resource", - $childId ) - unless $contract; - - $args{parent} = $this; - $args{id} = $childId; - $args{request} = $this->request; - - my $factory; - - if ( ref($contract) eq 'HASH' ) { - $factory = delete $contract->{class} || CustomResource; - hashApply( \%args, $contract ); - - Loader->default->Require($factory) - unless ref($factory); - } - else { - die OperationException->new( - "Unsupported contract for the child resource '$childId'", - $contract, $this->location ); - } - - return $factory->new(%args); -} - -sub PrepareResourcesCache { - my ($this) = @_; - - my @resources = ( $this->GetChildResources(), @{ $this->resources } ); - - my %nameMap; - my @rxMap; - - foreach my $res (@resources) { - - #skip resources without contract - next unless $res->{contract}; - - if ( my $name = $res->{name} ) { - $nameMap{$name} = $res; - } - if ( $res->{match} ) { - push @rxMap, $res; - } - } - - $this->regexResources( \@rxMap ); - $this->namedResources( \%nameMap ); -} - -sub AccessCheck { - my ( $this, $verb ) = @_; - - my $handler = $this->accessCheck; - - if ( ref($handler) eq 'CODE' ) { - return &$handler( $this, $verb ); - } -} - -sub GetChildResources { - -} - -sub HttpOptions { - my ($this) = @_; - - my @allow = $this->GetAllowedMethods(); - return HttpResponse->new( - status => '200 OK', - headers => { - allow => join( ',', @allow ) - } - ); -} - -sub _InvokeDelegate { - my $delegate = shift; - - return $delegate->(@_) if ref $delegate eq 'CODE'; - return $delegate->Invoke(@_) if eval { $delegate->can('Invoke') }; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C - базовый класс для ресурсов, -реальзуемых в коде. - -=head1 SYNOPSIS - -=begin code - -package MyApp::Web::Resources::ProfileResource; -use IMPL::declare { - base => [ - 'IMPL::Web::Application::CustomResource' => '@_' - ] -} - -sub HttpGet { - my ($this) = @_; - return $this->model; -} - -sub HttpPut { - my ($this,$action) = @_; - - my $form = MyApp::Web::Schema::UpdateUser->new(); - - $this->model->update( $form->Bind($action) ); -} - -sub GetChildResources { - return { - name => 'create', - contract => { - class => 'My::Web::FormResource', - formName => 'create', - schema => 'profile.schema' - } - }, - { - match => qr/^(.*)$/, - contract => { - class => 'My::Web::ItemResource' - } - } -} - -=end code - -=head1 MEMBERS - -=head2 C<[static]contractFactory> - -Фабрика, используемая для получения контракта ресурса. По умолчанию -C. - -=head2 C<[static]contractInstance> - -Экземпляр контракта для ресурса. Создается при первом обращении при помощи -метода C. - -=head2 C<[static]InitContract()> - -Создает новый экземпляр контракта, используя фабрику из свойства C. - -=head2 C<[static]CreateContract(%args)> - -Создает новый контракт, который при создании ресурсов будет передавать им в -конструкторе параметры C<%args>. Реализуется при помощи C -которой задается параметр ссылка на C<%args>, т.о. при создании ресурса, ему в -конструкторе будет передан список из ключей и значений хеша C<%args>, а затем -остальные аргументы. - -=head2 C<[static]CreateResource(%args)> - -Создает контракт по-умолчанию и вызывает у него метод C. - -=head2 C<[static]GetChildResources()> - -Статический метод, который должны переопределять новые классы ресурсов, у -которых есть дочерние ресурсы. - -=begin code - -package MyApp::Web::MyResource - -sub GetChildResources { - my $self = shift; - return - $self->SUPER::GetChildResources(), - { - name => 'info', - contract => $contractInfo - }; -} - -=end code - -Метод возвращает список из хешей, которые будут переданы в качестве параметра -C контракту данного ресурса. - -=cut diff -r de1f875e8875 -r 2287c72f303a Lib/IMPL/Web/Application/Resource.pm --- a/Lib/IMPL/Web/Application/Resource.pm Wed Feb 12 18:02:03 2014 +0400 +++ b/Lib/IMPL/Web/Application/Resource.pm Thu Feb 13 20:17:22 2014 +0400 @@ -163,7 +163,7 @@ myverb => sub { } }, #child resources can be a hash - chidren => { + children => { user => { # a resource class may be specified optionally # class => Resource, diff -r de1f875e8875 -r 2287c72f303a Lib/IMPL/Web/Application/ResourceBase.pm --- a/Lib/IMPL/Web/Application/ResourceBase.pm Wed Feb 12 18:02:03 2014 +0400 +++ b/Lib/IMPL/Web/Application/ResourceBase.pm Thu Feb 13 20:17:22 2014 +0400 @@ -78,10 +78,6 @@ # т.к. они просто освободятся несколько позже. if ( not $request->context->{resource} ) { $request->context->{resource} = $this; - $request->context->{environment} = sub { - carp "using request environment is deprecated"; - $this->PrepareEnvironment() - }; } return _InvokeDelegate( $operation, $this, $request ); diff -r de1f875e8875 -r 2287c72f303a Lib/IMPL/Web/Security.pm --- a/Lib/IMPL/Web/Security.pm Wed Feb 12 18:02:03 2014 +0400 +++ b/Lib/IMPL/Web/Security.pm Thu Feb 13 20:17:22 2014 +0400 @@ -20,7 +20,9 @@ }; sub AuthUser { - my ($this,$name,$package,$challenge) = @_; + my ($this,$name,$challenge,$package) = @_; + + $package ||= $this->interactiveAuthPackage; my $user = $this->users->GetById($name) or return {