Mercurial > pub > Impl
changeset 229:47f77e6409f7
heavily reworked the resource model of the web application:
*some ResourcesContraact functionality moved to Resource
+Added CustomResource
*Corrected action handlers
line wrap: on
line diff
--- a/Lib/IMPL/Class/Meta.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Class/Meta.pm Sat Sep 29 02:34:47 2012 +0400 @@ -69,7 +69,17 @@ } sub static_accessor { - my ($class,$name,$value,$clone) = @_; + my ($class,$name,$value,$inherit) = @_; + + $inherit ||= 'inherit'; + + my $method = "static_accessor_$inherit"; + + return $class->$method($name,$value); +} + +sub static_accessor_clone { + my ($class,$name,$value) = @_; $class = ref $class || $class; no strict 'refs'; @@ -81,18 +91,62 @@ $self = ref $self || $self; if ($class ne $self) { - $self->static_accessor( $name => $_[0] ); # define own class data + $self->static_accessor_clone( $name => $_[0] ); # define own class data + } else { + $value = $_[0]; + } + } else { + $self->static_accessor_clone($name => clone($value)); + } + }; + $value +}; + +sub static_accessor_inherit { + my ($class,$name,$value) = @_; + + no strict 'refs'; + + *{"${class}::$name"} = sub { + my $self = shift; + + if (@_ > 0) { + $self = ref $self || $self; + + if ($class ne $self) { + $self->static_accessor_inherit( $name => $_[0] ); # define own class data } else { $value = $_[0]; } } else { - ($clone and $class ne $self) - ? $self->static_accessor($name => clone($value),$clone) - : $value and $value ; - } - }; - $value -}; + $value ; + } + } +} + +sub static_accessor_own { + my ($class,$name,$value) = @_; + + no strict 'refs'; + + *{"${class}::$name"} = sub { + my $self = shift; + + if ($class ne $self) { + if (@_ > 0) { + $self->static_accessor_own( $name => $_[0] ); # define own class data + } else { + return; + } + } else { + if ( @_ > 0 ) { + $value = $_[0]; + } else { + return $value; + } + } + } +} sub _find_class_data { my ($class,$name) = @_; @@ -213,13 +267,39 @@ =back -=head2 C<static_accessor($name[,$value[,$clone]])> +=head2 C<static_accessor($name[,$value[,$inherit]])> Создает статическое свойство с именем C<$name> и начальным значением C<$value>. -Параметр C<$clone> контролирует то, как наследуются значения, если требуется каждому классу обеспечить -свое уникальное значение, то при первом обращении оно будет клонировано, по умолчанию клонирование не -происходит. +Параметр C<$inherit> контролирует то, как наследуются значения. + +=over + +=item * C<inherit> + +По умолчанию. Означает, что если для класса не определено значение, оно будет +получено от родителя. + +=item * C<clone> + +Если для класса не определено значение, то оно будет клонировано из +родительского значения при первом обращении. Полезно, когда родитель задает +значение по-умолчанию, которое разделяется между несколькими потомками, +которые модифицирю само значение (например значением является ссылка на хеш, +а потомки добавляют или меняют значения в этом хеше). + +=item * C<own> + +Каждый класс имеет свое собственное значение не зависящее от того, что было +у предка. Начальное значение для этого статического свойства C<undef>. + +=back + +Данный метод является заглушкой, он передает управление +C<static_accessor_inherit>, C<static_accessor_clone>, C<static_accessor_own> +соответственно. Эти методы можно вызывать явно +C<static_accessor_*($name[,$value])>. + =begin code @@ -227,12 +307,30 @@ use parent qw(IMPL::Class::Meta); __PACKAGE__->static_accessor( info => { version => 1 } ); +__PACKAGE__->static_accessor( mappings => { toString => \&ToString }, 'clone' ); +__PACKAGE__->static_accessor( _instance => undef, 'own' ); + +sub ToString { + "[object Foo]"; +} + +sub default { + my ($self) = @_; + + $self = ref $self || $self; + return $self->_instance ? $self->_instance : $self->_instance($self->new()); +} package Bar; use parent qw(Foo); -__PACKAGE__->info->{language} = 'English'; # Foo->info->{language} will become 'English' to!!! -__PACKAGE__->info({language => 'English'}); # will define own 'info' but will loose original data. +__PACKAGE__->info({language => 'English', version => 2}); # will define own 'info' but will loose original data. +__PACKAGE__->mappings->{sayHello} = \&SayHello; # will not affect Foo->mappings; + +package main; + +my $foo = Foo->default; # will be a Foo object +my $bar = Bar->default; # will be a Bar object =end code
--- a/Lib/IMPL/Code/Loader.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Code/Loader.pm Sat Sep 29 02:34:47 2012 +0400 @@ -35,10 +35,11 @@ my ($this,$package) = @_; if ($this->verifyNames) { - $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/ or die ArgumentException->new("package") ; + $package =~ m/^([a-zA-Z_0-9]+(?:::[a-zA-Z_0-9]+)*)$/ + or die ArgumentException->new(package => 'Invalid package name') ; } - $package = $this->prefix . $package if $this->prefix; + $package = $this->prefix . '::' . $package if $this->prefix; my $file = join('/', split(/::/,$package)) . ".pm";
--- a/Lib/IMPL/Config/Class.pm Thu Sep 13 17:55:01 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,56 +0,0 @@ -package IMPL::Config::Class; -use strict; -use warnings; - -use parent qw(IMPL::Config); -use IMPL::Exception; -use IMPL::Class::Property; -use Carp qw(carp); - -BEGIN { - carp "the module is deprecated"; - - public property Type => prop_all; - public property Parameters => prop_all; - public property IsSingleton => prop_all; - private property _Instance => prop_all; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my $this = shift; - - die new IMPL::Exception("A Type parameter is required") unless $this->Type; - - warn "IMPL::Config::Class is absolute, use IMPL::Config::Activator instead"; -} - -sub _is_class { - no strict 'refs'; - scalar keys %{"$_[0]::"} ? 1 : 0; -} - -sub instance { - my $this = shift; - - my $type = $this->Type; - - if ($this->IsSingleton) { - if ($this->_Instance) { - return $this->_Instance; - } else { - my %args = (%{$this->Parameters || {}},@_); - eval "require $type" unless _is_class($type); - my $inst = $type->new(%args); - $this->_Instance($inst); - return $inst; - } - } else { - my %args = (%{$this->Parameters || {}},@_); - eval "require $type" unless _is_class($type); - return $type->new(%args); - } -} - -1;
--- a/Lib/IMPL/Config/Container.pm Thu Sep 13 17:55:01 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,43 +0,0 @@ -package IMPL::Config::Container; -use strict; -use warnings; - -use parent qw(IMPL::Config); -use IMPL::Class::Property; -use Carp qw(carp); - -BEGIN { - carp "the module is deprecated"; - - public property Chidren => prop_all; -} - -sub CTOR { - my ($this,%args) = @_; - - $this->Chidren(\%args); -} - -sub save { - my ($this,$ctx) = @_; - - while (my ($key,$value) = each %{$this->Chidren}) { - $ctx->AddVar($key,$value); - } -} - -our $AUTOLOAD; -sub AUTOLOAD { - my $this = shift; - - (my $prop = $AUTOLOAD) =~ s/.*?(\w+)$/$1/; - - my $child = $this->Chidren->{$prop}; - if (UNIVERSAL::isa($child,'IMPL::Config::Class')) { - return $child->instance(@_); - } else { - return $child; - } -} - -1;
--- a/Lib/IMPL/Object/Autofill.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Object/Autofill.pm Sat Sep 29 02:34:47 2012 +0400 @@ -23,6 +23,7 @@ sub DisableAutofill { my $self = shift; + no strict 'refs'; my $class = ref $self || $self; *{"${class}::_impl_object_autofill"} = sub {};
--- a/Lib/IMPL/Web/Application.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Application.pm Sat Sep 29 02:34:47 2012 +0400 @@ -8,147 +8,159 @@ use IMPL::declare { require => { - TAction => 'IMPL::Web::Application::Action', - TResponse => 'IMPL::Web::Application::Response', - TFactory => '-IMPL::Object::Factory' - }, - base => { - 'IMPL::Config' => '@_', + TAction => 'IMPL::Web::Application::Action', + HttpResponse => 'IMPL::Web::HttpResponse', + TFactory => '-IMPL::Object::Factory', + Exception => 'IMPL::Exception', + InvalidOperationException => 'IMPL::InvalidOperationException', + Loader => 'IMPL::Code::Loader' + }, + base => [ + 'IMPL::Config' => '@_', 'IMPL::Object::Singleton' => '@_' - } + ], + props => [ + actionFactory => PROP_ALL, + handlers => PROP_ALL | PROP_LIST, + security => PROP_ALL, + options => PROP_ALL, + fetchRequestMethod => PROP_ALL, + output => PROP_ALL + ] }; -BEGIN { - public property errorHandler => PROP_ALL; - public property actionFactory => PROP_ALL; - public property handlers => PROP_ALL | PROP_LIST; - public property responseCharset => PROP_ALL; - public property security => PROP_ALL; - public property options => PROP_ALL; - public property fetchRequestMethod => PROP_ALL; -} - +sub CTOR { + my ($this) = @_; -#TODO: remove -sub handlersQuery { - carp "handlersQuery is obsolete use handlers instead"; - goto &handlers; -} - + die IMPL::InvalidArgumentException->new( "handlers", + "At least one handler should be supplied" ) + unless $this->handlers->Count; -sub CTOR { - my ($this) = @_; - - die IMPL::InvalidArgumentException->new("handlers","At least one handler should be supplied") unless $this->handlers->Count; - - $this->actionFactory(TAction) unless $this->actionFactory; - $this->responseCharset('utf-8') unless $this->responseCharset; - $this->fetchRequestMethod(\&defaultFetchRequest) unless $this->fetchRequestMethod; - $this->errorHandler(\&defaultErrorHandler) unless $this->errorHandler; + $this->actionFactory(TAction) unless $this->actionFactory; + $this->fetchRequestMethod( \&defaultFetchRequest ) + unless $this->fetchRequestMethod; } sub Run { - my ($this) = @_; - - my $handler; - - $handler = _ChainHandler($_,$handler) foreach $this->handlers; - - while (my $query = $this->FetchRequest()) { - - my $action = $this->actionFactory->new( - query => $query, - application => $this, - ); - - eval { - $action->response->charset($this->responseCharset); - - $handler->($action); - - $action->response->Complete; - }; - if ($@) { - my $e = $@; - # we are expecting this method to be safe otherwise we can trust nothing in this wolrd - $this->errorHandler()->($this,$action,$e); - } - } + my ($this) = @_; + + my $handler; + + $handler = _ChainHandler( $_, $handler ) foreach $this->handlers; + + while ( my $query = $this->FetchRequest() ) { + + my $action = $this->actionFactory->new( + query => $query, + application => $this, + ); + + eval { + my $result = $handler->($action); + + die InvalidOperationException->new( +"Invalid handlers result. A reference to IMPL::Web::HttpResponse is expexted." + ) unless eval { $result->isa(HttpResponse) }; + + $result->PrintResponse( $this->output ); + }; + if ($@) { + my $e = $@; + + HttpResponse->InternalError( + type => 'text/plain', + charset => 'utf-8', + body => $e + )->PrintResponse( $this->output ); + + } + } } sub _ChainHandler { - my ($handler,$next) = @_; - - if (ref $handler eq 'CODE') { + my ( $handler, $next ) = @_; + + if ( ref $handler eq 'CODE' ) { return sub { my ($action) = @_; - return $handler->($action,$next); + return $handler->( $action, $next ); }; - } elsif (eval { $handler->can('Invoke') } ) { + } + elsif ( eval { $handler->can('Invoke') } ) { return sub { my ($action) = @_; - return $handler->Invoke($action,$next); + return $handler->Invoke( $action, $next ); }; - } elsif (eval{ $handler->isa(TFactory) }) { + } + elsif ( eval { $handler->isa(TFactory) } ) { return sub { my ($action) = @_; my $inst = $handler->new(); - return $inst->Invoke($action,$next); - } - } elsif ($handler and not ref $handler and $handler =~ m/^(-)?(\w+(?:::\w+)*)$/) { + return $inst->Invoke( $action, $next ); + } + } + elsif ( $handler + and not ref $handler + and $handler =~ m/^(-)?(\w+(?:::\w+)*)$/ ) + { my $class = $2; - if (not $1) { - my $mod = $class; - $mod =~ s/::/\//g; - require "$mod.pm"; - - die IMPL::InvalidArgumentException->("An invalid handler supplied",$handler) unless $class->can('Invoke'); + if ( not $1 ) { + Loader->safe->Require($class); + die IMPL::InvalidArgumentException->( + "An invalid handler supplied", $handler + ) unless $class->can('Invoke'); } - + return sub { my ($action) = @_; my $inst = $class->new(); - return $inst->Invoke($action,$next); + return $inst->Invoke( $action, $next ); }; - } else { - die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler); + } + else { + die new IMPL::InvalidArgumentException( "An invalid handler supplied", + $handler ); } } sub FetchRequest { - my ($this) = @_; - - if( ref $this->fetchRequestMethod eq 'CODE' ) { - return $this->fetchRequestMethod->($this); - } else { - die new IMPL::Exception("Unknown fetchRequestMethod type",ref $this->fetchRequestMethod); - } + my ($this) = @_; + + if ( ref $this->fetchRequestMethod eq 'CODE' ) { + return $this->fetchRequestMethod->($this); + } + else { + die new IMPL::Exception( + "Unknown fetchRequestMethod type", + ref $this->fetchRequestMethod + ); + } } { - my $hasFetched = 0; + my $hasFetched = 0; - sub defaultFetchRequest { - my ($this) = @_; - return undef if $hasFetched; - $hasFetched = 1; - my $query = CGIWrapper->new(); - $query->charset($this->responseCharset); - return $query; - } + sub defaultFetchRequest { + my ($this) = @_; + return undef if $hasFetched; + $hasFetched = 1; + $this->output(*STDOUT); + my $query = CGIWrapper->new(); + return $query; + } } sub defaultErrorHandler { - my ($this,$action,$e) = @_; - warn $e; - if ( eval { $action->ReinitResponse(); 1; } ) { - $action->response->contentType('text/plain'); - $action->response->charset($this->responseCharset); - $action->response->status(500); - my $hout = $action->response->streamBody; - print $hout $e; - $action->response->Complete(); - } + my ( $this, $action, $e ) = @_; + warn $e; + if ( eval { $action->ReinitResponse(); 1; } ) { + $action->response->contentType('text/plain'); + $action->response->charset( $this->responseCharset ); + $action->response->status(500); + my $hout = $action->response->streamBody; + print $hout $e; + $action->response->Complete(); + } } package CGIWrapper; @@ -159,33 +171,38 @@ our $NO_DECODE = 0; sub param { - my $this = shift; - - return $this->SUPER::param(@_) if $NO_DECODE; - - if (wantarray) { - my @result = $this->SUPER::param(@_); - - return map Encode::is_utf8($_) ? $_ : Encode::decode($this->charset,$_,Encode::LEAVE_SRC), @result; - } else { - my $result = $this->SUPER::param(@_); - - return Encode::is_utf8($result) ? $result : Encode::decode($this->charset,$result,Encode::LEAVE_SRC); - } + my $this = shift; + + return $this->SUPER::param(@_) if $NO_DECODE; + + if (wantarray) { + my @result = $this->SUPER::param(@_); + + return map Encode::is_utf8($_) + ? $_ + : Encode::decode( $this->charset, $_, Encode::LEAVE_SRC ), @result; + } + else { + my $result = $this->SUPER::param(@_); + + return Encode::is_utf8($result) + ? $result + : Encode::decode( $this->charset, $result, Encode::LEAVE_SRC ); + } } sub upload { - my $this = shift; - - local $NO_DECODE = 1; - my $oldCharset = $this->charset(); - $this->charset('ISO-8859-1'); - - my $fh = $this->SUPER::upload(@_); - - $this->charset($oldCharset); - return $fh; + my $this = shift; + + local $NO_DECODE = 1; + my $oldCharset = $this->charset(); + $this->charset('ISO-8859-1'); + + my $fh = $this->SUPER::upload(@_); + + $this->charset($oldCharset); + return $fh; } 1; @@ -194,166 +211,32 @@ =pod +=head1 NAME + +C<IMPL::Web::Application> Класс для создания экземпляров приложения + =head1 SYNOPSIS =begin code -require MyApp; +use IMPL::require { + App => 'IMPL::Web::Application' +}; -my $instance = spawn MyApp('app.config'); +my $instance = App->spawn(); # will use ./IMPL/Web/Application.xml as configuration -$instance->Run(); +$instance->Run; =end code =head1 DESCRIPTION -C< inherits IMPL::Config, IMPL::Object::Singleton > - -Зкземпляр приложения содержит в себе глобальные настройки, реализует контроллер запросов, -в качестве источника запросов используется CGI или иной совместимый модуль. - -Процесс обработки запроса состоит из следующих частей - -=over - -=item 1 +Создает экземпляр объекта, который получает и обрабатывает C<HTTP> запрос. +Приложение можно загрузить из C<xml> файла в котором описано состояние свойств, +для этого используется механизм C<IMPL::Serialization>. -Получение cgi запроса - -=item 2 - -Создание объекта C<IMPL::Web::Application::Action> - -=item 3 - -Формирование цепочки вызовов при помощи C<< IMPL::Web::Application::Action->ChainHandler >> - -=item 4 - -Выполнение запроса C<< IMPL::Web::Application::Action->Invoke >> +Приложение представлет собой модульную конструкцию, которая состоит из цепочки +обработчиков. Цепочка обработчиков вызывается снизу вверх, при этом каждый +обработчик самостоятельно рекурсивно вызывает следующий (более высокого уровня). =cut - -Также приложение поддерживает отложенное создание объектов, которые по первому обращению -к свойствам. Это реализовано в базовом классе C< IMPL::Configuration >. Для настройки -активаторов можно использовать свойство C<options>, в которое должен быть помещен хеш -со ссылками на активаторы, см. пример ниже C<CONFIGURATION>. - -=head2 CONFIGURATION - -Ниже приведен пример конфигурации приложения - -=begin code xml - -<?xml version="1.0" encoding="UTF-8"?> -<Application id='app' type="Test::Web::Application::Instance"> - - <!-- Begin custom properties --> - <name>Sample application</name> - <dataSource type='IMPL::Config::Activator' id='ds'> - <factory>IMPL::Object</factory> - <parameters type='HASH'> - <db>data</db> - <user>nobody</user> - </parameters> - </dataSource> - <securityMod type='IMPL::Config::Activator'> - <factory>IMPL::Object</factory> - <parameters type='HASH'> - <ds refid='ds'/> - </parameters> - </securityMod> - <!-- End custom properties --> - - <!-- direct access to the activators --> - <options type="HASH"> - <dataSource refid='ds'/> - </options> - - <!-- Set default output encoding, can be changed due query handling --> - <responseCharset>utf-8</responseCharset> - - <!-- Actions creation configuration --> - <actionFactory type="IMPL::Object::Factory"> - - <!-- Construct actions --> - <factory>IMPL::Web::Application::Action</factory> - <parameters type='HASH'> - - <!-- with special responseFactory --> - <responseFactory type='IMPL::Object::Factory'> - - <!-- Where resopnses have a special streamOut --> - <factory>IMPL::Web::Application::Response</factory> - <parameters type='HASH'> - - <!-- in memory dummy output instead of STDOUT --> - <streamOut>memory</streamOut> - - </parameters> - </responseFactory> - </parameters> - </actionFactory> - - <!-- Query processing chain --> - <handlersQuery type="IMPL::Object::List"> - <item type="IMPL::Web::QueryHandler::PageFormat"> - <templatesCharset>cp1251</templatesCharset> - </item> - </handlersQuery> -</Application> - -=end code xml - -=head1 MEMBERS - -=over - -=item C<[get,set] errorHandler> - -Обработчик который будет вызван в случае возникновения необработанной ошибки -в процессе работы приложения. После чего приложение корректно завершается. - -=item C<[get,set] actionFactory> - -Фабрика объектов, которая используется приложением, для создания объектов -типа C<IMPL::Web::Application::Action> при обработки C<CGI> запросов. - -=begin code - -my $action = $this->actionFactory->new( - query => $query, - application => $this, -); - -=end code - -=item C< [get,set] fetchRequestMethod > - -Метод получения CGI запроса. Возвращает C<CGI> объект следующего запроса, если -запросов больше нет, то возвращает C<undef>. По-умолчанию использует C<defaultFetchRequest>. - -Может быть как ссылкой на функцию, так и объектом типа C<IMPL::Web::Application::RequestFetcher>. - -=item C< [get,set,list] handlersQuery > - -Список обработчиков запросов, которые будут переданы созданному объекту-действию. - -=item C< [get,set] responseCharset> - -Кодировка ответа клиенту. - -=item C< [get,set] security > - -Объект C<IMPL::Web::Security>, для работы с инфраструктурой безопасности. - -=item C< [get,set] options > - -Обычно ссылка на хеш с настраиваемыми объектами, используется для возможности -програмной настройки активаторов, т.к. напрямую через свойства приложения получить -к ним доступ не получится. - -=back - -=cut
--- a/Lib/IMPL/Web/Application/Action.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Application/Action.pm Sat Sep 29 02:34:47 2012 +0400 @@ -11,17 +11,12 @@ BEGIN { public property application => prop_get | owner_set; public property query => prop_get | owner_set; - public property response => prop_get | owner_set; - public property responseFactory => prop_get | owner_set; - public property context => prop_get | owner_set; private property _entryPoint => prop_all; } sub CTOR { my ($this) = @_; - $this->responseFactory('IMPL::Web::Application::Response') unless $this->responseFactory; - $this->response( $this->responseFactory->new(query => $this->query) ); $this->context({}); } @@ -35,56 +30,6 @@ } } -sub ReinitResponse { - my ($this) = @_; - - die new IMPL::InvalidOperationException("Response already sent") if $this->response->isHeaderPrinted; - - $this->response->Discard; - $this->response($this->responseFactory->new(query => $this->query)); -} - -sub ChainHandler { - my ($this,$handler) = @_; - - carp "deprecated, use Application->handlers instead"; - - my $delegateNext = $this->_entryPoint(); - - if (ref $handler eq 'CODE') { - $this->_entryPoint( sub { - $handler->($this,$delegateNext); - } ); - } elsif (ref $handler and UNIVERSAL::isa($handler,'IMPL::Web::QueryHandler')) { - $this->_entryPoint( sub { - $handler->Invoke($this,$delegateNext); - } ); - } elsif ($handler and not ref $handler) { - - if (my $method = $this->can($handler) ) { - $this->_entryPoint( sub { - $method->($this,$delegateNext); - } ); - } else { - { - no strict 'refs'; - eval "require $handler; 1;" or die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler,"Failed to load module") unless keys %{"${handler}::"}; - } - - if (UNIVERSAL::isa($handler,'IMPL::Web::QueryHandler')) { - $this->_entryPoint( sub { - $handler->Invoke($this,$delegateNext); - } ); - } else { - die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler); - } - } - } else { - die new IMPL::InvalidArgumentException("An invalid handler supplied",$handler); - } - -} - sub cookie { my ($this,$name,$rx) = @_; @@ -97,6 +42,16 @@ $this->_launder(scalar( $this->query->param($name) ), $rx ); } +sub requestMethod { + my ($this) = @_; + return $this->query->request_method; +} + +sub pathInfo { + my ($this) = @_; + return $this->query->path_info; +} + sub _launder { my ($this,$value,$rx) = @_; @@ -105,13 +60,13 @@ if ( my @result = ($value =~ m/$rx/) ) { return @result > 1 ? \@result : $result[0]; } else { - return undef; + return; } } else { return $value; } } else { - return undef; + return; } } @@ -132,11 +87,12 @@ =head1 MEMBERS -=head2 PROPERTIES +=head2 C<CTOR(%args)> -=over +Инициализирует новый экземпляр. Именованными параметрами передаются значения +свойств. -=item C< [get] application> +=head2 C< [get]application> Экземпляр приложения создавшего текущий объект @@ -144,31 +100,7 @@ Экземпляр C<CGI> запроса -=item C< [get] response > - -Ответ на C<CGI> заспрос C<IMPL::Web::Application::Response> - -=item C< [get] responseFactory > - -Фабрика ответов на запрос, используется для создания нового ответа -либо при конструировании текущего объекта C<IMPL::Web::Application::Action>, -либо при вызове метода C<ReinitResponse> у текущего объекта. - -По умолчанию имеет значение C<IMPL::Web::Application::Response> - =back -=head2 METHODS - -=over - -=item C< ReinitResponse() > - -Отмена старого ответа C<response> и создание вместо него нового. - -Данная операция обычно проводится при обработке ошибок, когда -уже сформированный ответ требуется отменить. Следует заметить, -что эта операция не возможна, если ответ частично или полностью -отправлен клиенту. Тогда возникает исключение C<IMPL::InvalidOperationException>. =cut
--- a/Lib/IMPL/Web/Application/ActionResult.pm Thu Sep 13 17:55:01 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,130 +0,0 @@ -use strict; -package IMPL::Web::Application::ActionResult; - -use CGI(); -use IMPL::lang qw(:declare); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException' - }, - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ] -}; - -BEGIN { - public property status => PROP_ALL; - public property type => PROP_ALL; - public property charset => PROP_ALL; - public property cookies => PROP_ALL; - public property headers => PROP_ALL; - public property body => PROP_ALL; -} - -sub CTOR { - my ($this) = @_; - - $this->headers({}); - $this->cookies({}); -} - -sub PrintResponse { - my ($this,$out) = @_; - - my $q = CGI->new({}); - - my %headers = %{$this->headers}; - - if(my $cookies = $this->cookies) { - $headers{-cookie} = [map _createCookie($_,$cookies->{$_}), keys %$cookies] if $cookies; - } - - $headers{'-status'} = $this->status || '200 OK'; - $headers{'-type'} = $this->type || 'text/html'; - - if(my $charset = $this->charset) { - $q->charset($charset); - binmode $out, ":encoding($charset)"; - } - - $q->header(\%headers); - - if(my $body = $this->body) { - if(ref $body eq 'CODE') { - $body->($out); - } else { - print $out $body; - } - } -} - -#used to map a pair name valie to a valid cookie object -sub _createCookie { - return UNIVERSAL::isa($_[1], 'CGI::Cookie') ? $_[1] : CGI::Cookie->new(-name => $_[0], -value => $_[1] ); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::ActionResult> - Результат обработки C<HTTP> запроса. - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Базовый класс для ответов приложения на C<HTTP> запрос. Каждый вид ответа, -например - -Данный объект используется для формирования и передачи данных C<HTTP> ответа -напрямую. Основными полями являются C<body> и C<status>. - -Кроме свойств относящихся непосредственно к самому C<HTTP> ответу, данный объект -может содержать свойства относящиеся к процессу обработки запроса, например -механизму формирования представления. - -=head1 MEMBERS - -=head2 C<[get,set]status> - -Статус который будет отправлен сервером клиенту, например, C<200 OK> или -C<204 No response>. Если не указан, то будет C<200 OK>. - -=head2 C<[get,set]type> - -Тип содержимого, которое будет передано клиенту, если не указано, будет -C<text/html>. - -=head2 C<[get,set]charset> - -Кодировка в которой будут переданны данные. Следует задавать если и только, если -передается текстовая информация. Если указана кодировка, то она будет -автоматически применена к потоку, который будет передан методу C<PrintResponse>. - -=head2 C<[get,set]cookies> - -Опционально. Ссылка на хеш с печеньками. - -=head2 C<[get,set]headers> - -Опционально. Ссылка на хеш с дополнительными полями заголовка ответа. Формат -имен полей как у модуля C<CGI>. - -=head2 C<[get,set]body> - -Тело ответа. Может быть как простой скаляр, который будет приведен к строке и -выдан в поток вывода метода C<PrintResponse>. Также может быть ссылкой на -процедуру, в таком случае будет вызвана эта процедура и ей будет передан -первым параметром поток для вывода тела ответа. - -=head2 C<PrintResponse($outStream)> - -Формирует заголовок и выводит ответ сервера в указанный параметром поток. - -=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/Application/CustomResource.pm Sat Sep 29 02:34:47 2012 +0400 @@ -0,0 +1,113 @@ +package IMPL::Web::Application::CustomResource; +use strict; + +use IMPL::lang qw(:constants); + +use IMPL::declare { + require => { + CustomResourceContract => 'IMPL::Web::Application::CustomResourceContract' + }, + base => [ + 'IMPL::Web::Application::Resource' => '@_' + ] +}; + +__PACKAGE__->static_accessor(contractFactory => CustomResourceContract ); +__PACKAGE__->static_accessor_own(_contractInstance => undef); + +sub contractInstance { + my ($self) = @_; + + $self = ref $self || $self; + $self->_contractInstance ? $self->_contractInstance : $self->InitContract(); +} + +sub InitContract { + my ($self) = @_; + + $self->_contractInstance( $self->contractFactory->new(resourceFactory => $self ) ); +} + +sub GetChildResources { + +} + + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application::CustomResource> - базовый класс для ресурсов, +реальзуемых в коде. + +=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) ); +} + +=end code + +=head1 MEMBERS + +=head2 C<[static]contractFactory> + +Фабрика, используемая для получения контракта ресурса. По умолчанию +C<IMPL::Web::Application::CustomResourceContract>. + +=head2 C<[static]contractInstance> + +Экземпляр контракта для ресурса. Создается при первом обращении при помощи +метода C<InitContract()>. + +=head2 C<[static]InitContract()> + +Создает новый экземпляр контракта, используя фабрику из свойства C<contractFactory>. + +=head2 C<[static]GetChildResources()> + +Статический метод, который должны переопределять новые классы ресурсов, у +которых есть дочерние ресурсы. + +=begin code + +package MyApp::Web::MyResource + +sub GetChildResources { + my $self = shift; + return + $self->SUPER::GetChildResources(), + { + + } + { + + }; +} + +=end code + + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/Application/CustomResourceContract.pm Sat Sep 29 02:34:47 2012 +0400 @@ -0,0 +1,76 @@ +package IMPL::Web::Application::CustomResourceContract; +use strict; + +use IMPL::lang qw(:constants); +use IMPL::declare { + require => { + NotAllowedException => 'IMPL::Web::NotAllowedException', + OperationContract => 'IMPL::Web::Application::OperationContract' + }, + base => [ + 'IMPL::Web::Application::ResourceContract' => '@_' + ] +}; + +our %RESOURCE_BINDINGS = ( + GET => 'HttpGet', + POST => 'HttpPost', + PUT => 'HttpPut' + DELETE => 'HttpDelete', + HEAD => 'HttpHead' +); + +sub CTOR { + my ($this) = @_; + + $this->verbs->{options} = OperationContract->new( binding => \&_HttpOptionsBinding ); + + while(my ($verb,$methodName) = each %RESOURCE_BINDINGS) { + $this->verbs->{lc($verb)} = OperationContract->new ( + binding => sub { + my ($resource,$action) = @_; + + if ($resource->can($methodName)) { + return $resource->$methodName($action); + } else { + die NotAllowedException->new(allow => join(',', _GetAllowedHttpMethods($resource))); + } + + } + ); + } +} + +sub _HttpOptionsBinding { + my ($resource) = @_; + + my @allow = _GetAllowedHttpMethods; + retrun HttpResponse->new( + status => '200 OK', + headers => { + allow => join ( ',', @allow ) + } + ); +} + +sub _GetAllowedHttpMethods { + my ($resource) = @_; + return grep $resource->can($RESOURCE_BINDINGS{$_}), values %RESOURCE_BINDINGS; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application::CustomResourceContract> - контракт для веб-ресурсов, +реальзуемых в коде см. C<IMPL::Web::Application::CustomResource}>. + +=head1 DESCRIPTION + +Данный класс не используется напрямую. + +=cut
--- a/Lib/IMPL/Web/Application/OperationContract.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Application/OperationContract.pm Sat Sep 29 02:34:47 2012 +0400 @@ -1,22 +1,48 @@ package IMPL::Web::Application::OperationContract; use strict; +use IMPL::lang qw(:declare); use IMPL::declare { - base => [ - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - ], - props => [ - binding => PROP_ALL, - response => PROP_ALL - ] + require => { + 'Exception' => 'IMPL::Exception', + 'ArgumentException' => '-IMPL::ArgumentException', + 'ResourceBaseClass' => 'IMPL::Web::Application::ResourceBase' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + ], + props => [ + binding => PROP_ALL, + success => PROP_ALL, + error => PROP_ALL + ] }; sub Invoke { - my ($this, $resource, $httpAction) = @_; + my ( $this, $resource, $request ) = @_; + + die ArgumentException( resource => 'A valid resource is required' ) + unless eval { $resource->isa(ResourceBaseClass) }; + + my $result = eval { + _InvokeDelegate($this->binding, $resource, $request) + }; - if ($this->) + if (my $e = $@) { + $result = _InvokeDelegate($this->error, $resource, $request, $e); + } else { + $result = _InvokeDelegate($this->success, $resource, $request, $result); + } + + return $result; +} + +sub _InvokeDelegate { + my $delegate = shift; + return $delegete->(@_) if ref $delegate eq 'CODE'; + return $delegate->Invoke(@_) if eval { $delegate->can('Invoke')}; } 1; @@ -40,14 +66,17 @@ }; my $operation = OperationContract->new( - bind => sub { - my ($resource,$model,$itemName) = @_; + binding => sub { + my ($resource,$request) = @_; + + my $itemName = $request->param('itemName', qr/^(\w+)$/); - return $model->findItem($itemName); + return $model->FindItem($itemName); }, - response => RedirectResponse->new( - locator => $relativeLocator - ) + success => sub { + my ($resource,$request,$result) = @_; + return HttpReponse->Redirect(location => $resource->location->Child($result->id)); + } ); my $response = $operation->InvokeOperation($resource); @@ -56,23 +85,89 @@ =head1 DESCRIPTION -Связывает методы предметной области с операциями над ресурсами. Для связи с -моделью используется функция, которой будут переданы параметры: +Для орисания контракта операции используется понятие делегата, тоесть объекта, +представляющего собой функцию, либо объект, имеющий метод C<Invoke>. + +Поскольку предметная область должна быть отделена от +контроллеров веб-сервиса, она ничего не знает про существование ресурсов и их +организацию и тем более о протоколе C<HTTP>, поэтому все вещи, связанные с +формированием ответов сервера, представлениями данных и т.п. должны выполняться +самими контроллерами. Поведение контроллеров описывается контрактами, в которых +указываются делегаты для реализации необходимого функционала, для корректного +отображения ресурсов в объекты предметной области и обратно. + +Контракт операции состоит из нескольких свойств, осуществляющих привязку к +предметной области: =over -=item C<$reousrce> Ресурс для которого выполняется операция +=item * C<binding> -=item C<$model> Объект модели данных, связанный с данным ресурсом, тоже, что -и C<<>$resource->model>> только для краткости +делегат для привязки операции над ресурсом к предметной области. + +=item * C<success> -=item C<$action> Контекст текущего C<HTTP> запроса. +делегат для обработки результат операции, например для формирования ответа с +перенаправлением. + +=item * C<error> -=back +делегат для обработки исключительной ситуации, может быть использован для +формирования представления для повторного ввода данных на форме. -Результат выполнения будет передан дополнительному обработчику C<response>, -который выполнит необходимое преобразование. +=back =head1 MEMBERS -=cut \ No newline at end of file +=head2 C<[get,set] binding> + +Привязка операции к ресурсу, например + +=begin code + +$operationContract->binding(sub { + my ($resource,$action) = @_; + $resource->model +}) + +=end code + +Может быть как ссылка на процедуру, так и ссылкой на объект, имеющий метод +C<Invoke>. + +=head2 C<[get,set] success> + +Обрабатывает результат привязки к предметной области. + +=begin code + +# redirect (for example after POST) +$operationContract->success(sub { + my ($resource,$action,$result) = @_; + + return IMPL::Web::HttpResponse + ->Redirect($resource->location->Child($result->id)); +}) + +=end code + +Может быть как ссылка на процедуру, так и ссылкой на объект, имеющий метод +C<Invoke>. + +=head2 C<[get,set] error> + +Обрабатывает ошибку возникшую при выполнении привязки к предметной области. + +=begin + +$operationContract->error(sub { + my ($resource,$action,$error) = @_; + + $action->form->errors->{''} = $error; + + return $resource->model; +}); + +=end + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/Application/Resource.pm Sat Sep 29 02:34:47 2012 +0400 @@ -0,0 +1,148 @@ +package IMPL::Web::Application::Resource; +use strict; + +use IMPL::lang qw(:constants); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException', + OperationException => '-IMPL::InvalidOperationException', + NotAllowedException => 'IMPL::Web::NotAllowedException', + NotFoundException => 'IMPL::Web::NotFoundException' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Web::Application::ResourceInterface' => undef + ], + props => [ + parent => PROP_GET | PROP_OWNERSET, + model => PROP_GET | PROP_OWNERSET, + id => PROP_GET | PROP_OWNERSET, + contract => PROP_GET | PROP_OWNERSET, + location => PROP_GET | PROP_OWNERSET + ] +}; + +sub CTOR { + my ( $this, %args ) = @_; + + die ArgumentException->new( id => 'A resource identifier is required' ) + unless $args{id}; + die ArgumentException->new( contract => 'A contract is required' ) + unless $args{id}; + + $this->parent( $args{parent} ); + $this->model( $args{model} ); + $this->id( $args{id} ); + $this->contract( $args{contract} ); + + # если расположение явно не указано, что обычно делается для корневого + # ресурса, то оно вычисляется автоматически, либо остается не заданным + $this->location( $args{location} + || eval { $this->parent->location->Child( $this->id ) } ); + ) + +} + +sub InvokeHttpVerb { + my ( $this, $verb, $action ) = @_; + + my $verb = $this->contract->verbs->{ lc($verb) }; + + die NotAllowedException->new( + allow => join( ',' map( uc, keys %{ $this->contract->verbs } ) ) ) + unless $verb; + + return $verb->Invoke( $this, $action ); +} + +# это реализация по умолчанию, базируется информации о ресурсах, содержащийся +# в контракте. +sub FetchChildResource { + my ( $this, $childId ) = @_; + + my $info = $this->contract->FindChildResourceInfo($childId); + + die NotFoundException->new() unless $info; + + my $binding = $this->{binding}; + my $contract = $this->{contract} + or die OperationException->new("Can't fetch a contract for the resource", $childId); + + my %args = ( + parent => $this, + id => $childId + ); + + $args{model} = _InvokeDelegate($binding,$this); + + return $contract->CreateResource(%args); +} + +sub _InvokeDelegate { + my $delegate = shift; + + return $delegete->(@_) if ref $delegate eq 'CODE'; + return $delegate->Invoke(@_) if eval { $delegate->can('Invoke')}; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application::Resource> - Web-ресурс. + +=head1 SYNOPSIS + +Класс для внутреннего использования. Объединяет в себе контракт и модель данных. +Основная задача - обработать поступающий от контроллера запрос на вызов C<HTTP> +метода. + +Экземпляры данного класса передаются в качестве параметров делегатам +осуществляющим привязку к модели в C<IMPL::Web::Application::ResourceContract> +и C<IMPL::Web::Application::OperationContract>. + +=head1 DESCRIPTION + +Весь функционал ресурса, поддерживаемые им C<HTTP> методы определяются +контрактом. Однако можно реализовывать ресурсы, которые не имеют контракта +или он отличается от того, что предоставляется стандартно +C<IMPL::Web::Application::ResourceContract>. + +Каждый ресурс является контейнером, тоесть позволяет получить дочерний ресурс +по идентифифкатору, если таковой имеется, тоесть ресурс, у которого нет дочерних +ресурсов на самом деле рассматривается как пустой контейнер. + +С ресурсом непосредственно взаимодействует котроллер запросов +C<IMPL::Web::Handler::RestController>, вызывая два метода. + +=over + +=item * C<FetchChildResource($childId)> + +Данный метод возвращает дочерний ресурс, соответствующий C<$childId>. +Текущая реализация использует метод C<FindChildResourceInfo> контракта текущего +ресурса, после чего создает дочерний ресурс. + +Если дочерний ресурс не найден, вызывается исключение +C<IMPL::Web::NotFoundException>. + +=item * C<InvokeHttpVerb($verb,$action)> + +Обрабатывает запрос к ресурсу. Для этого используется контракт ресурса, в +нем выбирается соответсвующий C<IMPL::Web::Application::OperationContract>. +Затем найденный контракт для указанной операции используется для обработки +запроса. + +=back + +Если объект реализует два вышеуказанных метода, он является веб-ресурсом, а +детали его реализации, котнракт и прочее уже не важно, поэтому можно реализовать +собственный класс ресурса, например унаследованный от +C<IMPL::Web::Application::CustomResource>. + +=cut
--- a/Lib/IMPL/Web/Application/ResourceContract.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Application/ResourceContract.pm Sat Sep 29 02:34:47 2012 +0400 @@ -1,114 +1,92 @@ package IMPL::Web::Application::ResourceContract; use strict; -use IMPL::lang qw(:declare); +use IMPL::lang qw(:constants); use IMPL::declare { require => { - 'Exception' => 'IMPL::Exception', - 'ArgumentException' => '-IMPL::ArgumentException', + 'Exception' => 'IMPL::Exception', + 'ArgumentException' => '-IMPL::ArgumentException', 'KeyNotFoundException' => '-IMPL::KeyNotFoundException', - 'ResourceClass' => 'IMPL::Web::Application::Resource' - }, - base => [ - 'IMPL::Object' => undef - ] + 'ResourceClass' => 'IMPL::Web::Application::Resource' + }, + base => [ 'IMPL::Object' => undef ], + props => [ + resourceFactory => PROP_ALL, + verbs => PROP_ALL, + _namedResources => PROP_ALL, + _regexpResources => PROP_ALL | PROP_LIST, + ] }; -BEGIN { - public property resourceFactory => PROP_ALL; - public property operations => PROP_ALL; - private property _namedResources => PROP_ALL; - private property _regexpResources => PROP_ALL | PROP_LIST; -} - sub CTOR { my $this = shift; my %args = @_; - + $this->resourceFactory( $args{resourceFactory} || ResourceClass ); - - my $resources = $args{resources} || []; - my $operations = $args{operations} || {}; - - die ArgumentException->new(resources => 'resources parameter must be a reference to an array') - unless ref $resources eq 'ARRAY'; - - die ArgumentException->new(opearations => 'operations parameter must be a reference to a hash') - unless ref $operations eq 'HASH'; - + + my $resources = $args{resources} || []; + my $verbs = $args{verbs} || {}; + + die ArgumentException->new( + resources => 'resources parameter must be a reference to an array' ) + unless ref $resources eq 'ARRAY'; + + die ArgumentException->new( + opearations => 'operations parameter must be a reference to a hash' ) + unless ref $verbs eq 'HASH'; + + $this->verbs( + { map { lc($_), $verbs->{$_} } keys %$verbs } ); + my %nameMap; - - foreach my $res (@$resources) { + + foreach my $res (@$verbs) { next unless $res->{contract}; - if(my $name = $res->{name}) { + if ( my $name = $res->{name} ) { $nameMap{$name} = $res; } - if($res->{match}) { + if ( $res->{match} ) { $this->_regexpResources->Append($res); } } - - $this->_namedResources(\%nameMap); + + $this->_namedResources( \%nameMap ); +} + +sub AddChildResourceContract { + my ($this,$res) = @_; + + die ArgumentException->new(res => "A valid child resource definition") + unless ref $res eq 'HASH'; + + $this->_namedResources->{$res->{name}} = $res if $res->{name}; + $this->_regexpResources->Append($res) if $res->{match}; + + return; } sub CreateResource { my $this = shift; my %args = @_; - - return $this->resourceFactory->new ( - %args, - contract => $this - ); -} -sub FindChildResourceContractInfo { - my ($this,$name) = @_; - - if(my $contract = $this->_namedResources->{$name}) { - return $contract; - } else { - foreach my $info ( $this->_regexpResources ) { - my $rx = $info->{match}; - return $info if $name =~ m/$rx/; - } - } - - return undef; + return $this->resourceFactory->new( %args, contract => $this ); } -sub CreateChildResource { - my $this = @_; - my %args = @_; - - my $id = $args{id} or die ArgumentException( id => 'id parameter must be specified'); - my $parent = $args{parent}; - my $model = $parent->model if $parent; - my $binding, $childContract, @bindingVars; - - if(my $info = $this->_namedResources->{$id}) { - @bindingVars = ($id); - $childContract = $info->{contract}; - $binding = $info->{bind}; - } else { - foreach my $info ( $this->_regexpResources ) { - my $rx = $info->{match}; - next unless $rx; - if( @bindingVars = ($id =~ m/$rx/) ) { - $childContract = $info->{contract}; - $binding = $info->{bind}; - } - } - } - - if ($childContract) { - my $childModel = $binding ? $binding->($parent,$model,@bindingVars) : undef; - - return $childContract->CreateResource( - %args, - model => $childModel - ); - } else { - die KeyNotFoundException->new($id); - } +sub FindChildResourceInfo { + my ( $this, $name ) = @_; + + if ( my $info = $this->_namedResources->{$name} ) { + return $info, [$name]; + } + else { + foreach my $info ( $this->_regexpResources ) { + my $rx = $info->{match}; + if(my @childId = $name =~ m/$rx/) { + return $info, \@childId; + } + } + } + + return; } 1; @@ -131,26 +109,50 @@ }; my $contract = ResourceContract->new( - operations => { + verbs => { get => OperationContract->new( - bind => sub { + binding => sub { + my ($resource,$action) = @_; return "Hello!"; } - ) + ), + post => OperationContract->new( + parameters => [ + IMPL::Transform::DataToModel->new() # создаем преобразование для формы + ], + binding => sub { + my ($resource,$action,$data) = @_; + return $resource->model->AddItem($data); + }, + success => sub { + my ($resource,$action,$result) = @_; + return IMPL::Web::HttpResponse->Redirect( + location => $resource->location->Child($result->id) + ) + }, + error => sub { + my ($resource,$action,$error) = @_; + $action->errors->Append($error); + return $resource->model; + } + + ), }, resources => [ { name => 'info', - bind => sub { + binding => sub { return $_[0]->model->info; }, contract => ResourceContract->new( - get => OperationContract->new( - bind => sub { - my ($resource,$model) = @_; - return $model; # or the same: $resource->model; - } - ) + verbs => { + get => OperationContract->new( + binding => sub { + my ($resource,$action) = @_; + return $resource->model; + } + ) + } ) } ] @@ -164,13 +166,163 @@ id => 'item-something' ); -my $child = $contract->CreateChildResource( - parent => $resource, - id => 'info' -); +my $child = $contract->FetchChildResource('info'); =end code =head1 DESCRIPTION -=cut \ No newline at end of file +Контракт описывает структуру Веб-ресурса и отображение операций над ним в методы +предметной области. Контракты используются инфраструктурой и пользователь +не использует их напрямую, до тех пор пока не требуется изменить стандартный +функционал. + + +Ресурс представляе собой набор контрактов операций, соответствующих методам +C<HTTP> которые доступны у данного ресурса. Кроме операций ресурс состоит из +дочерних ресурсов, которые могут соответствовать регулярным выражениям, либо +иметь фиксированные имена. + +Каждая операция над ресурсом C<IMPL::Web::Application::OperationContract> +описывается преобразованием параметров, привязкой к предметной области, +дополнительным обработчиком результата выполнения привязки, либо обработчиком +исключения, если привязку не удалось выполнить. + +Основное назначение контракта - создавать объекты ресурсов, над которыми +контроллер запросов C<HTTP> сможет выполнить операцию. Контракт может создавать +дочерние ресурсы, на основе указанного родительского ресурса и идетификатора +нового ресурса. При этом будет найден подходящий контракт для дочернего ресурса +и с его помощью создан дочерний ресурс. + +=head2 Динамический контракт + +Основная функция контракта - превращать данные модели предметной области в +данные ресурсной модели, тоесть в ресурсы, для чего каждый контракт обязан +реализовывать метод C<CreateResource(%args)>. + +Результатом выполнения этого метода должен быть Web-ресурс, см. +C<IMPL::Web::Application::Resource>. Другими словами не существует жесткого +требования к реализации самого контракта, как и того, что созданный ресурс +должен ссылаться именно на этот контракт (да и вообще ссылаться на контракт). + +Таким образом можно реализовать контракт, который выполняет роль посредника, +ниже приведен пример, который выбирает нужный контракт на основе типа модели +переданной для создания ресурса. + +=begin code + +package My::Web::Application::ContractMapper; +use strict; +use IMPL::lang qw(:constants); +use IMPL::declare { + require => { + ForbiddenException => 'IMPL::Web::Forbidden' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + ], + props => [ + map => PROP_GET | PROP_OWNERSET + ] +} + +sub CreateResource { + my ($this,%args) = @_; + + my $type = ref $args{model} || '_default'; + + my $contract = $this->map->{$type}; + + die ForbiddenException->new() + unless $contract; + + return $contract->CreateResource(%args); +} + +=end code + +=head1 MEMBERS + +=head2 C<CTOR(%args)> + +=over + +=item * C<resourceFactory> + +Фабрика объектов C<IMPL::Object::Factory> которая будет использоваться при +создании новых ресурсов. По-умолчанию C<IMPL::Web::Application::Resource>. + +=item * C<operations> + +Хеш с доступными действиями над C<HTTP> ресурсом, ключом является имя ресурса, +значением C<IMPL::Web::Application::OperationContract>. + +=item * C<resources> + +Ссылка на массив хешей, каждый хеш описывает правила, как получить дочерний +ресурс и связать его с контрактом. Ниже преведено описание элементов хеша. + +=over + +=item * C<name> + +Имя дочернегно ресурса. + +=item * C<match> + +Регулярное выражение, которому должно удовлетворять имя дочернего ресурса. + +=item * C<bind> + +Делегат, получающий модель для дочернего ресурса. Первым параметром ему +передается родительский объект, далее передаются граппы из регулярного +выражения, если это ресурс с именем удовлетворяющим регулярному выражению из +элемента C<match>, либо имя ресурса, если это ресурс с именем, указанным в +элементе C<name>. + +=item * C<contract> + +Ссылка на C<IMPL::Web::Application::ResourceContract> для дочернего ресурса. +У данного контракта используется только метод C<CreateContract>. + +=back + +По крайней мере C<name> или C<match> должны присутсвовать. + +=back + +=head2 C<CreateResource(%args)> + +Создает ресурс, параметры C<%args> будут переданы напрямую констркутору +ресурса, для создания ресурса используется фабрика C<resourceFactory>. +При создании, конгструктору ресурса, будет передана ссылка на текущй контракт. + +По-сути никакого дополнительного функционала данный метод не несет. + +=head2 C<FindChildResourceInfo($childId)> + +Используется для поиска информации о дочернем ресурсе, возвращает список из двух +элементов. C<($info,$childIdParts)> + +=over + +=item * C<$info> + +Информация о контракте дочернего ресурса, как правило это ссылка на хеш, похожий +по формату на + +=back + +=head2 C<[get]verbs> + +Хеш с доступными действиями над C<HTTP> ресурсом, все имена операций приведены +к нижнему регистру. + +=begin code + +my $result = $contract->verbs->{get}->Invoke($resource,$action); + +=end code + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/Application/ResourceInterface.pm Sat Sep 29 02:34:47 2012 +0400 @@ -0,0 +1,89 @@ +package IMPL::Web::Application::ResourceInterface; +use strict; + +use IMPL::require { + Exception => 'IMPL::Exception', + NotImplException => '-IMPL::NotImplementedException' +}; + +sub InvokeHttpVerb { + die NotImplException->new(); +} + +sub FetchChildResource { + die NotImplementedException->new(); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::Application::ResourceInterface> - Интерфейс для Web-ресурса. + +=head1 SYNOPSIS + +=begin code + +package MyApp::Web::Resource; +use IMPL::lang qw(:constants); +use IMPL::declare { + require => { + NotAllowedException => 'IMPL::Web::NotAllowedException' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Web::Application::ResourceInterface' => undef + ], + props => [ + model => PROP_ALL + ] +}; + +sub InvokeHttpVerb { + my ($this,$verb,$action) = @_; + + if($verb eq 'GET') { + return $this->model; + } else { + die NotAllowedException->new(allow => 'GET'); + } +} + +sub FetchChildResource { + # no child resources + return; +} + +=end code + +=head1 DESCRIPTION + +Данный модуль объявляет только интерфейс, тоесть в нем есть заглушки для функций +которые необходимо реализовать. + +Для создания класса, который может быть использоваться для создания Web-ресурсов +нужно унаследовать данный интерфейс и реализовать его методы. + +=head1 MEMBERS + +=head2 C<InvokeHttpVerb($verb,$action)> + +Выполняет операцию над ресурсом и возвращает результат ее выполнения. +Результатом может быть произвольный объект, который будет передан по цепочке +обработчиков приложения для формирования ответа вервера, либо +C<IMPL::Web::HttpResponse>, который описывает (не обязательно полностью) ответ. +В любом случае результат будет передан далее в цепочку обработчиков и может +быть изменен. + +=head2 C<FetchChildResource($childId)> + +Используется для получения дочернего ресурса (который содержится в данном +контейнере). Метод должен возвращать либо Web-ресурс +C<IMPL::Web::Application::ResourceInterface>, либо C<undef> если дочерний ресурс +не найден. + +=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Application/Response.pm Thu Sep 13 17:55:01 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,296 +0,0 @@ -package IMPL::Web::Application::Response; -use strict; - -use parent qw(IMPL::Object IMPL::Object::Autofill); - -require IMPL::Exception; -require CGI; -require CGI::Cookie; - -use Carp; -use Encode; -use IMPL::Class::Property; - -#todo: add binary method to set a binary encoding, set it automatic when type isn't a text - -BEGIN { - # автозаполнение буде происходить в порядке объявления - public property query => prop_get | owner_set; # cgi query - public property status => prop_all, { validator => \&_checkHeaderPrinted }; - public property contentType => prop_all, { validator => \&_checkHeaderPrinted }; # String - public property charset => { get => \&_charset, set => \&_charset }, { validator => \&_checkHeaderPrinted }; - public property expires => prop_all, { validator => \&_checkHeaderPrinted }; - public property cookies => prop_all, { validator => \&_checkHeaderPrinted }; # Hash - - public property buffered => prop_all, { validator => \&_canChangeBuffer }; # Boolean - public property streamOut => prop_get | owner_set; # stream - public property streamBody => {get => \&getStreamBody }; # stream - public property isHeaderPrinted => prop_get | owner_set; # Boolean - - private property _bufferBody => prop_all; - private property _streamBody => prop_all; -} - -__PACKAGE__->PassThroughArgs; - -our %CTOR = ( - 'IMPL::Object::Autofill' => sub { - my %args = @_; - - $args{query} = CGI->new($args{query} || {}); - - %args; - } -); - -sub CTOR { - my ($this,%args) = @_; - - if ($this->streamOut and lc $this->streamOut eq 'memory') { - my $dummy = ''; - open my $hout, '>:encoding(utf8)', \$dummy or die new IMPL::Exception("Failed to create memory stream",$!); - $this->streamOut($hout); - } elsif (not $this->streamOut) { - $this->streamOut(*STDOUT); - } else { - die new IMPL::InvalidArgumentException("Invalid parameter value",$this->streamOut); - } - - $this->buffered(1) unless defined $this->buffered; - binmode $this->streamOut, ":encoding(".$this->charset.")"; -} - -sub _checkHeaderPrinted { - my ($this,$value) = @_; - - die new IMPL::InvalidOperationException() if $this->isHeaderPrinted; -} - -sub _canChangeBuffer { - my ($this,$value) = @_; - - die new IMPL::InvalidOperationException() if $this->isHeaderPrinted or $this->_streamBody; -} - -sub _charset { - my $this = shift; - - if (@_) { - my $charset = $this->query->charset(@_); - - my $hout = $this->streamOut; - - binmode $hout; - binmode $hout, ":encoding($charset)"; - - return $charset; - } else { - return $this->query->charset; - } -} - -sub _PrintHeader { - my ($this) = @_; - - unless ($this->isHeaderPrinted) { - $this->isHeaderPrinted(1); - - my %opt; - - $opt{-type} = $this->contentType if $this->contentType; - $opt{-status} = $this->status if $this->status; - $opt{-expires} = $this->expires if $this->expires; - - my $refCookies = $this->cookies; - $opt{-cookie} = [map _createCookie($_,$refCookies->{$_}), keys %$refCookies] if $refCookies; - - my $hOut = $this->streamOut; - - print $hOut $this->query->header( - %opt - ); - } -} - -sub _createCookie { - return UNIVERSAL::isa($_[1], 'CGI::Cookie') ? $_[1] : CGI::Cookie->new(-name => $_[0], -value => $_[1] ); -} - -sub setCookie { - my ($this,$name,$value) = @_; - - unless ($this->cookies) { - $this->cookies({$name,$value}); - } else { - $this->_checkHeaderPrinted(); - $this->cookies->{$name} = $value; - } - return $value; -} - -sub getStreamBody { - my ($this) = @_; - - return undef unless $this->streamOut; - - unless ($this->_streamBody) { - if ($this->buffered) { - my $buffer = ""; - - $this->_bufferBody(\$buffer); - - open my $hBody, ">:encoding(utf-8)", \$buffer or die new IMPL::Exception("Failed to create buffer",$!); - - Encode::_utf8_on($buffer); - - $this->_streamBody($hBody); - } else { - $this->_PrintHeader(); - $this->_streamBody($this->streamOut); - } - } - - return $this->_streamBody; -} - -sub Complete { - my ($this) = @_; - - return 0 unless $this->streamOut; - - my $hOut = $this->streamOut; - - $this->_PrintHeader(); - - close $this->_streamBody(); - - if ($this->buffered) { - print $hOut ${$this->_bufferBody}; - } - - $this->_bufferBody(undef); - $this->streamOut(undef); - - return 1; -} - -sub Discard { - my ($this) = @_; - - carp "Discarding sent response" if $this->isHeaderPrinted; - - $this->_streamBody(undef); - $this->_bufferBody(undef); - $this->streamOut(undef); -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::Response> - Ответ веб сервера непосредственно клиенту. - -=head1 DESCRIPTION - -C<[Infrastructure]> - -Позволяет сформировать основные свойства заголовка и тело ответа. - -Создается объектом C<IMPL::Web::Application::Action> в процессе обработки запроса. - -Может использоваться обработчиками C<IMPL::Web::QueryHandler> в процессе выполнения запроса. - -Объект позволяет буфферизировать вывод в тело ответа, что позволяет отменить или изменить -ответ в последний момент. Свойство C< isHeaderPrinted > используется для определения факта -отправлки данных клиенту. - -=head1 PROPERTIES - -=head2 HTTP Header - -Свойства отвечающие за заголовок HTTP ответа. Эти своства могут быть изменены до тех пор пока -не будет отправлен заголовок. В противном случае выдается исключение C< IMPL::InvalidOperationException >. - -=over - -=item C< [get] query > - -CGI запрос, который используется для вывода данных, заголовка и пр. Существует всегда. - -=item C< [get,set] status > - -Код HTTP. Например, '200 OK'. По умолчанию не установлен, при отправке клиенту бедт отправлен '200 ОК'. - -=item C< [get,set] contentType > - -Тип MIME. По умолчанию не установлен, подразумивается 'text/html'. - -=item C< [get,set] charset > - -Кодировка, синоним свойства query->charset. - -=item C< [get,set] expires > - -Определяет время жизни контента, например '+10m'. По умолчанию не задано и не передается. - -=item C< [get,set] cookies > - -Хеш массив с cookies, например C< { cart => ['foo','bar'], display => 'list' } >. - -=back - -=head2 Response behaviour - -Свойства отвечающие за поведение ответа. - -=over - -=item C< [get,set] buffered > - -C< True > - то тело ответа пишется в буффер и будет отправлено при вызове метода C< Complete >, -заголовок также будет отправлен после вызова метода C< Complete >. - -C< False > - тело ответа пишется непосредственно в поток к клиенту, при этом заголовок -будет отправлен при первом обращении к свойству C< streamBody > - -Это свойство можно менять до первого обращения к потоку для записи в тело ответа. - -=item C< [get] streamOut > - -Стандартный вывод CGI приложения. - -=item C< [get] streamBody > - -Поток для записи в тело ответа. - -=item C< [get] isHeaderPrinted > - -Признак того, что заголовок уже был отправлен клиенту. - -=back - -=head1 METHODS - -=over - -=item C< Complete > - -Завершает отправку ответа. - -=item C< Discard > - -Отменяет отправку ответа, при этом если часть данных (например, заголовок) -уже была отправлена, выдает предупреждение в STDERR. - -=back - -=head1 REMARKS - -Данный объект является автозаполняемым, т.е. все его свойства можно задать через -именованные параметры конструктора. - -=cut
--- a/Lib/IMPL/Web/Application/RestBaseResource.pm Thu Sep 13 17:55:01 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ -package IMPL::Web::Application::RestBaseResource; -use strict; - -use IMPL::lang qw(:declare :constants); -use IMPL::declare { - require => { - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::InvalidArgumentException', - NotImplException => '-IMPL::NotImplementedException', - ForbiddenException => 'IMPL::Web::ForbiddenException', - TTransform => '-IMPL::Transform' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_' - } -}; - - -BEGIN { - public property id => PROP_GET | PROP_OWNERSET; - public property parent => PROP_GET | PROP_OWNERSET; - public property contract => PROP_GET | PROP_OWNERSET; - protected property final => PROP_ALL; -} - -sub target { - shift; -} - -sub CTOR { - my ($this) = @_; - - die ArgumentException->new("id","Identifier is required for non-root resources") if $this->id and not length $this->id; - die ArgumentException->new("A contract is required") unless $this->contract; -} - -sub GetHttpImpl { - my($this,$method) = @_; - - my %map = ( - GET => 'GetImpl', - PUT => 'PutImpl', - POST => 'PostImpl', - DELETE => 'DeleteImpl' - ); - - return $map{$method}; -} - -sub InvokeHttpMethod { - my ($this,$method,$action) = @_; - - my $impl = $this->GetHttpImpl($method) || 'HttpFallbackImpl'; - - return $this->$impl($action); -} - -sub GetImpl { - die NotImplException->new(); -} - -sub PutImpl { - die NotImplException->new(); -} - -sub PostImpl { - die NotImplException->new(); -} - -sub DeleteImpl { - die NotImplException->new(); -} - -sub HttpFallbackImpl { - die ForbiddenException->new(); -} - -sub FetchChildResource { - return undef; -} - - -1; - -__END__ - -=pod - - - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Application/RestCustomResource.pm Thu Sep 13 17:55:01 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,63 +0,0 @@ -package IMPL::Web::Application::RestCustomResource; -use strict; - -use IMPL::lang qw(:declare :constants); -use IMPL::declare { - require => { - Exception => "IMPL::Exception", - ArgumentException => '-IMPL::InvalidArgumentException', - ForbiddenException => 'IMPL::Web::ForbiddenException', - NotFoundException => 'IMPL::Web::NotFoundException' - }, - base => { - 'IMPL::Web::Application::RestBaseResource' => '@_' - } -}; - -BEGIN { - public property get => PROP_GET | PROP_OWNERSET; - public property put => PROP_GET | PROP_OWNERSET; - public property post => PROP_GET | PROP_OWNERSET; - public property delete => PROP_GET | PROP_OWNERSET; -} - -sub FetchChildResource { - my ($this,$id,$action) = @_; - - die NotFoundException->new() if $this->final; - - return $this->contract->Transform( $this->GetImpl($action), { parent => $this, id => $id } )->FetchChildResource($id,$action); -} - -sub GetImpl { - my ($this,$action) = @_; - - my $method = $this->get or die ForbiddenException->new(); - return $this->InvokeMember($method,$action); -} - -sub PutImpl { - my ($this,$action) = @_; - my $method = $this->put or die ForbiddenException->new(); - return $this->InvokeMember($method,$action); -} - -sub PostImpl { - my ($this,$action) = @_; - my $method = $this->post or die ForbiddenException->new(); - return $this->InvokeMember($method,$action); -} - -sub DeleteImpl { - my ($this,$action) = @_; - my $method = $this->delete or die ForbiddenException->new(); - return $this->InvokeMember($method,$action); -} - -sub InvokeMember { - my ($this,$method,$action) = @_; - - return $this->$method($action); -} - -1; \ No newline at end of file
--- a/Lib/IMPL/Web/Application/RestResource.pm Thu Sep 13 17:55:01 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,601 +0,0 @@ -package IMPL::Web::Application::RestResource; -use strict; - -use IMPL::lang qw(:declare :constants is :hash); -use IMPL::Exception(); - -use IMPL::declare { - require => { - ForbiddenException => 'IMPL::Web::ForbiddenException', - NotFoundException => 'IMPL::Web::NotFoundException', - InvalidOpException => '-IMPL::InvalidOperationException', - ArgumentException => '-IMPL::InvalidArgumentException', - TTransform => '-IMPL::Transform', - TResolve => '-IMPL::Config::Resolve', - CustomResource => 'IMPL::Web::Application::RestCustomResource' - }, - base => { - 'IMPL::Web::Application::RestCustomResource' => '@_' - } -}; - -BEGIN { - # объект, который представляется данным ресурсом - public property target => PROP_GET | PROP_OWNERSET; - - # получение индекса, тоесть обращение по пути '/foo/bar/' - public property index => PROP_GET | PROP_OWNERSET; - - # получение дочернего ресурса по идентификатору, который - # удовлетворяет childRegex - public property fetch => PROP_GET | PROP_OWNERSET; - - # публикует ресурсы связанные с методами объекта - public property methods => PROP_GET | PROP_OWNERSET; - - # формат идентификаторов дочерних ресурсов для метода fetch - public property childRegex => PROP_GET | PROP_OWNERSET; - - # поддержка форм браузеров при помощи создания дочерних ресурсов - public property enableForms => PROP_GET | PROP_OWNERSET; - - # контракты именованных дочерних ресурсов - public property nestedResources => PROP_GET | PROP_OWNERSET; -} - -sub CTOR { - my ($this,%args) = @_; - - die ArgumentException->new("target") unless $this->target; - - $this->final($this->childRegex ? 0 : 1); - $this->methods({}) unless $this->methods; - - $this->index($this->get) unless defined $this->index; - - if ($this->enableForms) { - $this->methods->{create} = { - get => $this->get, - post => $this->post, - final => 1 # this resource doesn't have any children - } if $this->post; - - $this->methods->{edit} = { - get => $this->get, - post => $this->put, - final => 1 # this resource doesn't have any children - } if $this->put; - - $this->methods->{delete} { - get => $this->get, - post => $this->delete, - final => 1 # this resource doesn't have any children - } if $this->delete; - } -} - -# создает дочерний ресурс из описания, однако все методы созданного -# ресурса переадресуются к его родителю, это нужно, чтобы публиковать -# методы и свойства объекта -sub _CreateSubResource { - my ($this,$resource,$id) = @_; - - my %methods = map { - my $method = $resource->{$_}; - $_ => sub { - my ($this,$action) = @_; - return $this->parent->InvokeMember($method,$action); - }; - } grep $resource->{$_}, qw(get post put delete); - - return CustomResource->new( - %methods, - final => $resource->{final}, - parent => $this, - id => $id, - contract => $this->contract - ); -} - -sub FetchChildResource { - my ($this,$id,$action) = @_; - - my $rx = $this->childRegex; - - my $res; - - if (length $id == 0) { - - my $method = $this->index; - die ForbiddenException->new() unless $method; - - $res = $this->InvokeMember($method,$action); - - } elsif ($this->methods and my $resource = $this->methods->{$id}) { - - return $this->_CreateSubResource($resource,$id); - - } elsif ($rx and $id =~ m/^$rx$/ and my $method = $this->fetch) { - - $method = { - method => $method, - parameters => 'id' - } unless ref $method; - - $res = $this->InvokeMember($method,$action, { id => $id } ); - - } - - die NotFoundException->new() unless defined $res; - - return $this->contract->Transform($res, {parent => $this, id => $id} ); -} - -sub InvokeMember { - my ($this,$method,$action,$predefined) = @_; - - die ArgumentException->new("method","No method information provided") unless $method; - - #normalize method info - if (not ref $method) { - $method = { - method => $method - }; - } - - if (ref $method eq 'HASH') { - my $member = $method->{method} or die InvalidOpException->new("A member name isn't specified"); - - $member = $member->Invoke($this) if eval { $member->isa(TResolve) }; - - my @args; - - if (my $params = $method->{parameters}) { - if (ref $params eq 'HASH') { - @args = map { - $_, - $this->MakeParameter($params->{$_},$action,$predefined) - } keys %$params; - } elsif (ref $params eq 'ARRAY') { - @args = map $this->MakeParameter($_,$action,$predefined), @$params; - } else { - @args = ($this->MakeParameter($params,$action,$predefined)); - } - } - return $this->target->$member(@args); - } elsif (ref $method eq TResolve) { - return $method->Invoke($this); - } elsif (ref $method eq 'CODE') { - return $method->($this,$action); - } else { - die InvalidOpException->new("Unsupported type of the method information", ref $method); - } -} - -sub MakeParameter { - my ($this,$param,$action,$predefined) = @_; - - my $params = hashApply( - { - id => $this->id, - action => $action, - query => $action->query - }, - $predefined || {} - ); - - - - if ($param) { - if (is $param, TTransform ) { - return $param->Transform($action->query); - } elsif ($param and not ref $param) { - return $params->{$param} || $action->query->param($param); - } else { - die InvalidOpException->new("Unsupported parameter mapping", $param); - } - } else { - return undef; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::RestResource> - ресурс Rest вебсервиса. - -=head1 SYNOPSIS - -=begin text - -[REQUEST] -GET /artists - -[RESPONSE] -<artists> - <artist id="1"> - <name>The Beatles <name/> - </atrist> - <artist id="2"> - <name>Bonobo</name> - </artist> -</artists> - -[REQUEST] -GET /artists/1/cds?title='Live at BBC' - -[RESPONSE] -<cds> - <cd id="14"> - <title>Live at BBC 1</title> - </cd> - <cd id="15"> - <title>Live at BBC 2</title> - </cd> -</cds> - -[REQUEST] -GET /cds/15 - -[RESPONSE] -<cd id="15"> - <title>Live at BBC 2</title> -</cd> - -=end text - -=begin code - -use IMPL::require { - TRes => 'IMPL::Web:Application::RestResource', - DataContext => 'My::App::DataContext' -}; - -my $cds = TRes->new( - DataContext->Default, - { - methods => { - history => { - get => { - method => 'GetHistory', - parameters => [qw(from to)] - }, - }, - rating => { - get => { - method => 'GetRating' - } - post => { - method => 'Vote', - parameters => [qw(id rating comment)] - } - } - } - index => { - method => 'search', - paremeters => [qw(filter page limit)] - }, - fetch => 'GetItemById' - } -); - -=end code - -=head1 DESCRIPTION - -Каждый ресурс представляет собой коллекцию и реализует методы C<HTTP> C<GET,POST,PUT,DELETE>. - -Вызов каждого из этих методов позволяет выполнить одну из операций над ресурсом, однако -операций может быть больше, для этого создаются дочерние ресурсы (каждый из которых также -может иметь четыре метода C<GET,POST,PUT,DELETE>), однако обращения к методам у дочерних -ресурсов отображаются в вызовы методов у родительского ресурса. - -Такой подход позволяет расширить функциональность не изменяя стандарт C<HTTP>, а также обойти -ограничения браузеров на методы C<PUT,DELETE>. - -Данный тип ресутсов расчитан на использование с конфигурацией, которую можно будет -сохранить или прочитать, например, из файла. Для этого у ресурса есть ряд настроек, -которые позволяют в простой форме задать отображения между C<HTTP> методами и методами -объекта представленного данным ресурсом. - -Следует отметить, что свойство C<final> вычисляется автоматически. - - -=head2 HTTP METHODS - -=head3 C<GET> - -Возвращает данные из текущего ресурса. Обращение к данному методу не должно вносить -изменений в ресурсы. - -=head3 C<PUT> - -Обновляет ресурс. Повторное обращение к данному методу должно приводить к одному и -томуже результату. - -=head3 C<DELETE> - -Удаляет ресурс. - -=head3 C<POST> - -Данный метод может вести себя как угодно, однако обычно он используется для добавления -нового дочернего ресурса в коллекцию,также может использоваться для вызова метода, в случае -если происходит публикация методов в качестве дочерних ресурсов. - -=head1 BROWSER COMPATIBILITY - -Однако существует проблема с браузерами, поскольку тег C<< <form> >> реализет только методы -C<GET,POST>. Для решения данной проблемы используется режим совместимости C<enableForms>. В -случае когда данный режим активен, автоматически публикуются дочерние ресурсы C<create,edit,delete>. - -Данные ресуры пбликуются как методы, что означает то, что обращения к ним будут превращены в -выполнения соответсвующих методов на родительском объекте. - -=head2 C<create> - -По сути данные ресурсы не является необходимостью, однако создается для целостности модели. - -=head3 C<GET> - -Передает управление методу C<get> - -=head3 C<POST> - -Передает управление методу C<post> - -=head2 C<edit> - -=head3 C<GET> - -Передает управление методу C<get> - -=head3 C<POST> - -Передает управление методу C<put>, как если бы он был выполнен непосредственно у -родительского ресурса. - -=head2 C<delete> - -=head3 C<GET> - -Передает управление методу C<get> - -=head3 C<POST> - -Передает управление методу C<delete>, , как если бы он был выполнен непосредственно у -родительского ресурса. - -=head1 METHOD DEFINITIONS - -Все методы ресурсов данного типа задаются описаниями, хранящимися в соответствующих -свойствах. Когда наступает необходимость вызова соответствующего метода, его описание -бедется из свойства и передается методу C<InvokeMember>, который и производит вызов. - -=head2 C<HASH> - -Содержит в себе описание метода, который нужно вызвать, а также его параметры. - -=over - -=item C<method> - -Имя метода который будет вызван. - -=item C<paremeters> - -Описание параметров метода, может быть либо массивом, либо хешем, либо простым -значением. - -=over - -=item C<ARRAY> - -Метод получает список параметров, каждый элемент данного массива будет превращен -в параметр при помощи метода C<MakeParameter> - -=item C<HASH> - -Метод получает список параметров, который состоит пар ключ-значение, каждое значение -данного хеша будет превращено в зачение параметра метода при помощи метода C<MakeParameter>. -Ключи хеша изменениям не подвергаются. - -=item Простое значение - -Метод получает одно значение, которое будет получено из текущего при помощи C<MakeParameter>. - -=back - -=back - -=head2 C<CODE> - -Если в описании метода находится ссылка на функцию, то эта функция будет вызвана с параметрами. -Данный вариант полезен когда ресурсы создаются програмно обычного механизма описаний не достаточно -для реализации требуемого функционала. - -=over - -=item C<$resource> - -Текущий ресурс у которого производится вызов метода. - -=item C<$action> - -Текущий запрос C<IMPL::Web::Application::Action>. - -=back - -=head2 Простое значение - -Интерпретируется как имя метода у объекта данных текущего ресурса. - -=head1 MEMBERS - -=head2 C<[get]id> - -Идентификатор текущего ресурса. - -=head2 C<[get]target> - -Объект данных (может быть и класс, поскольку у него будут только вызываться -методы), обеспечивающий функционал ресурса. - -=head2 C<[get]parent> - -Родительский ресурс, в котором находится текущий ресурс. Может быть C<undef>, -если текущий ресурс является корнем. - -=head2 C<[get]methods> - -Содержит описания методов, которые будут публиковаться как дочерние ресурсы. - -=head2 C<[get]childRegex> - -Содержит регулярное выражение для идентификаторов дочерних объектов. Если оно -не задано, то данный ресурс не является коллекцией. - -=head2 C<[get]fetch> - -Содержит описание метода для получения дочернего объекта. Если данный метод -отсутствует, то дочерние ресурсы не получится адресовать относительно данного. -По умолчанию получает идентификатор дочернего ресурса первым параметром. - -=head2 C<[get]index> - -Описание метода для получения списка дочерних объектов. По умолчанию не -получает параметров. - -=head2 C<[get]post> - -Описание метода для добавление дочернего ресурса. По умолчанию получает -объект C<CGI> описывабщий текущий запрос первым параметром. - -=head2 C<[get]put> - -Описание метода для обновления дочернего ресурса. По умолчанию получает -объект C<CGI> текущего запроса. - -=head2 C<[get]delete> - -Описание метода для удаления дочернего ресурса. По умолчанию не получает -параметров. - -=head2 C<GetImpl($action)> - -=over - -=item C<$action> - -Текущий запрос C<IMPL::Web::Application::Action>. - -=back - -Переадресует запрос нужному методу внутреннего объекта C<target> при -помощи C<InvokeMember>. - -=head2 C<PutImpl($action)> - -=over - -=item C<$action> - -Текущий запрос C<IMPL::Web::Application::Action>. - -=back - -Переадресует запрос нужному методу внутреннего объекта C<target> при -помощи C<InvokeMember>. - -=head2 C<PostImpl($action)> - -=over - -=item C<$action> - -Текущий запрос C<IMPL::Web::Application::Action>. - -=back - -Переадресует запрос нужному методу внутреннего объекта C<target> при -помощи C<InvokeMember>. - -=head2 C<DeleteImpl($action)> - -=over - -=item C<$action> - -Текущий запрос C<IMPL::Web::Application::Action>. - -=back - -Переадресует запрос нужному методу внутреннего объекта C<target> при -помощи C<InvokeMember>. - -=head2 C<InvokeMember($memberInfo,$action,$params)> - -=over - -=item C<$memberInfo> - -Описание члена внутреннего объекта C<target>, который нужно вызвать. - -=item C<$action> - -Текущий запрос C<IMPL::Web::Application::Action>. - -=item C<$params> - -Ссылка на хеш с предопределенными параметрами. - -=back - -Вызывает метод внутреннего объекта C<target>, предварительно подготовив -параметры на основе описания C<$memberInfo> и при помощи С<MakeParameter()>. - -=head2 C<MakeParameter($paramDef,$action)> - -=over - -=item C<$paramDef> - -Описание параметра, может быть C<IMPL::Transform> или простая строка. - -Если описание параметра - простая строка, то ее имя либо - -=over - -=item C<id> - -Идентификатор ресурса - -=item C<query> - -Объект C<CGI> текущего запроса - -=item C<action> - -Текущий запрос C<IMPL::Web::Application::Action> - -=item C<любое другое значение> - -Интерпретируется как параметр текущего запроса. - -=back - -Если описание параметра - объект C<IMPL::Transform>, то будет выполнено это преобразование над C<CGI> -объектом текущего запроса C<< $paramDef->Transform($action->query) >>. - -=item C<$action> - -Текущий запрос - -=back - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/Application/ViewResult.pm Thu Sep 13 17:55:01 2012 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -package IMPL::Web::Application::ViewResult; -use strict; - -use IMPL::lang qw(:declare); -use IMPL::declare { - base => [ - 'IMPL::Web::Application::ActionResult' => '@_' - ] -}; - -BEGIN { - public property model => PROP_ALL; -} - -sub CTOR { - my $this = shift; - $this->status('200 OK') unless $this->status; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::Web::Application::ViewResult> - Результат для которого требуется создать -представление. - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - View => 'IMPL::Web::Application::ViewResult' -}; - -sub ViewItem { - my ($this,$id) = @_; - - my $view = View->new(model => $this->items->find($id)); - $view->cookies->{'Some cookie'} = 'some value'; - return $view; -} - -=end code - -=head1 DESCRIPTION - -Наследует C<IMPL::Web::Application::ActionResult>. - -Позволяет сформировать C<HTTP> ответ с указанием расширенных свойств и данных. -Как правило данный класс не требуется использовать на прямую, он создается -системой по-умолчанию для представления результатов методов предметной области. - -Следует избегать использование данного класса непосредственно при реализации -предметной области, поскольку она должна быть отделена от контроллеров и -представления. - -=head1 MEMBERS - -=head2 C<[get,set]model> - -Объект для которого необходимо построить представление. - -=cut \ No newline at end of file
--- a/Lib/IMPL/Web/AutoLocator.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/AutoLocator.pm Sat Sep 29 02:34:47 2012 +0400 @@ -1,7 +1,7 @@ package IMPL::Web::AutoLocator; use strict; -use IMPL::lang qw(:declare :constants :hash); +use IMPL::lang qw(:constants :hash); use URI; use URI::Escape; use IMPL::declare { @@ -13,17 +13,16 @@ 'IMPL::Object' => undef, 'IMPL::Object::Autofill' => '@_', 'IMPL::Object::Serializable' => '@_' + ], + props => [ + base => PROP_GET | PROP_OWNERSET, + view => PROP_ALL, + query => PROP_ALL, + hash => PROP_ALL ] }; -BEGIN { - public property base => PROP_GET | PROP_OWNERSET; - public property view => PROP_ALL; - public property query => PROP_ALL; - public property hash => PROP_ALL; -} - -sub Fetch { +sub Child { my $this = shift; my $child = shift or die ArgumentException->new("a child resource identifier is required"); die ArgumentException->new("a child resource can't be a reference") if ref $child; @@ -72,7 +71,7 @@ return if $method eq 'DESTROY'; my $this = shift; - return $this->Fetch($method,@_); + return $this->Child($method,@_); } @@ -83,14 +82,14 @@ =head1 NAME -=head1 SYNOPSIS +C<IMPL::Web::AutoLocator> - Обертка вокруг адреса ресурса. -C<IMPL::Web::AutoLocator> - Обертка вокруг адреса ресурса. +=head1 SYNOPSIS =begin code use IMPL::require { - Locator => 'IMPL::Web::Locator' + Locator => 'IMPL::Web::AutoLocator' }; my $bugTracker = Locator->new(base => "http://myhost.org/bugzilla")->SetView("cgi"); @@ -101,27 +100,80 @@ my $page = $wiki->Main->HowTo; +my $images = Locator->new(base => "http://static.myhost.org/images", view => "png"); + +my $editIco = $images->icons->small->edit; + =end code =head1 DESCRIPTION -Для удобстав навигации по ресурсам, полностью отражает классическую структуру иерархически -организованных ресурсов. позволяет гибко работать с параметрами запроса и хешем. Для постоты -чтения реализует метод C<AUTOLOAD> для доступа к дочерним ресурсам. +Для удобстав навигации по ресурсам, полностью отражает классическую структуру +иерархически организованных ресурсов. позволяет гибко работать с параметрами +запроса и хешем. Для постоты чтения реализует метод C<AUTOLOAD> для доступа +к дочерним ресурсам. =head1 MEMBERS -=head2 C<CTOR(base => $url,view => $extension, query => $hashQuery, hash => $fragment)> +=head2 C<CTOR(%args)> + +Создает новый объект расположение. Позволяет задать путь, расширение, параметры +запроса и фрагмент ресурса. + +=over + +=item * C<base> + +Строка с базовым адресом для дочерних ресурсов. + +=item * C<view> -Создает новый объект расположение. Позволяет задать путь, расширение, параметры запроса и фрагмент ресурса. +Задает суфикс, обозначающий представление ресурса, аналогично расширению у +файлов. Данный суффикс может использоваться контроллером для выбора +представления ресурса. + +=item * C<query> + +Ссылка на хеш с параметрами запроса + +=item * C<hash> + +Часть C<uri> обозначающая фрагмент документа (все, что идет после символа C<#>). + +=back -=head2 C<Fetch($child[,$query])> +=head2 C<Child($child[,$query])> + +Получает расположение дочернего ресурса. При этом cоздается новый объект адреса ресурса. + +=head2 C<SetView($view)> + +Позволяет указать представление (расширение) у текущего адреса ресурса. Изменяет +представление и возвращает измененный адрес ресурса. + +=head2 C<[get]base> + +Базовый адрес, относительно которого будут получены дочерние ресурсы. -Получает расположение дочернего ресурса. При этом моздается новый объект адреса ресурса. +=head2 C<[get,set]view> + +Представление для ресурсов, аналогично расширению у файлов. + +=head2 C<[get,set]query> + +Ссылка на хеш с параметрами для C<GET> запроса. + +=head2 C<[get,set]hash> + +Часть адреса ресурса, отвечающая за фрагмент. + +=head2 C<[get]url> + +Объект C<URI> для текущего адреса. =head2 C<AUTLOAD> -Перенаправляет вызовы методов в метод C<Fetch> передавая первым параметром имя метода. +Перенаправляет вызовы методов в метод C<Child> передавая первым параметром имя метода. =cut
--- a/Lib/IMPL/Web/Exception.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Exception.pm Sat Sep 29 02:34:47 2012 +0400 @@ -2,12 +2,18 @@ use strict; use warnings; -use parent qw(IMPL::Exception); +use IMPL::lang qw(:constants); +use IMPL::declare { + base => [ + 'IMPL::Exception' => '@_' + ], + props => [ + headers => PROP_ALL + ] +}; -__PACKAGE__->PassThroughArgs; - -sub code { - 400; +sub status { + "500 Internal error"; } 1; @@ -43,8 +49,12 @@ =head1 MEMBERS -=head2 C<code()> +=head2 C<status()> Возвращает C<HTTP> код ошибки. Каждый класс иключений должен переопределить данный метод. +=head2 C<[get,set]headers> + +Ссылка на хеш с параметрами заголовка. + =cut \ No newline at end of file
--- a/Lib/IMPL/Web/ForbiddenException.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/ForbiddenException.pm Sat Sep 29 02:34:47 2012 +0400 @@ -7,8 +7,8 @@ } }; -sub code { - 403 +sub status { + "403 Forbidden" } 1;
--- a/Lib/IMPL/Web/Handler/ErrorHandler.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Handler/ErrorHandler.pm Sat Sep 29 02:34:47 2012 +0400 @@ -7,6 +7,8 @@ require => { WebException => 'IMPL::Web::Exception', ArgumentException => '-IMPL::InvalidArgumentException', + IOException => '-IMPL::IOException', + HttpResponse => 'IMPL::Web::HttpResponse' }, base => { 'IMPL::Object' => undef, @@ -42,9 +44,6 @@ }; if (my $err = $@) { - $action->ReinitResponse(); - $action->response->charset('utf-8'); - $action->response->contentType($this->contentType); my $vars = { error => $err @@ -52,17 +51,24 @@ my $code = 500; - $code = $err->code if eval { $err->isa(WebException) }; + if (eval { $err->isa(WebException) }) { + ($code) = ($err->status =~ m/^(\d+)/); + } - $action->response->status("$code"); - my $doc = $this->loader->document( $this->errors->{$code} || $this->fallback, $vars ); - my $hout = $action->response->streamBody; - print $hout $doc->Render($vars); + my $text = $doc->Render($vars); + + $result = HttpResponse->new( + status => $err->status, + type => $this->contentType, + charset => 'utf-8', + headers => $err->headers, + body => $text + ); } return $result; @@ -76,8 +82,36 @@ =head1 NAME +C<IMPL::Web::Handler::ErrorHandler> - обертка для обработки исключений. + =head1 SYNOPSIS +Используется в цеопчке обработчиков приложения. + +=begin code xml + + <handlers type="ARRAY"> + <item type="IMPL::Web::Handler::ErrorHandler"> + <contentType>text/html</contentType> + <loader refid="tt-loader"/> + <errors type="HASH"> + <error extname="500">errors/500</error> + <error extname="404">errors/404</error> + <error extname="403">errors/403</error> + </errors> + <fallback>errors/500</fallback> + </item> + </handlers> + +=end code xml + =head1 DESCRIPTION +Позволяет создать представление для ресурса в случае ошибки, для этого +используется соответствие представлений и кодов ошибок. + +В результате обработчик либо прозрачно передает результат вышестоящего +обработчика нижестоящему, либо создает C<IMPL::Web::HttpResponse> с +соответствующим статусом и содержанием. + =cut \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/RestController.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Handler/RestController.pm Sat Sep 29 02:34:47 2012 +0400 @@ -2,69 +2,72 @@ use strict; use IMPL::lang qw(:declare :constants); - - use IMPL::declare { require => { + ResourceInterface => 'IMPL::Web::Application::ResourceInterface', Exception => 'IMPL::Exception', ArgumentExecption => '-IMPL::InvalidArgumentException', - HttpException => 'IMPL::Web::Exception', - NotFoundException => 'IMPL::Web::NotFoundException' + NotFoundException => 'IMPL::Web::NotFoundException' }, base => { 'IMPL::Object' => undef, 'IMPL::Object::Autofill' => '@_', 'IMPL::Object::Serializable' => undef - } + }, + props => [ + rootResource => PROP_GET | PROP_OWNERSET, + trailingSlash => PROP_GET | PROP_OWNERSET + ] }; -BEGIN { - public property root => PROP_GET | PROP_OWNERSET; - public property contract => PROP_GET | PROP_OWNERSET; -} - sub CTOR { my ($this) = @_; - die ArgumentException->new("root") unless $this->root; - die ArgumentException->new("contract") unless $this->contract; + die ArgumentException->new(rootResource => "A web-resource is required") + unless eval { $this->rootResource->isa(ResourceInterface) }; + } +sub GetResourcePath { + my ($this,$action) = @_; + + my $pathInfo = $action->pathInfo; + my @segments; + + if (length $pathInfo) { + + @segments = split(/\//, $pathInfo, $this->trailingSlash ? -1 : 0); + + # remove first segment since it's always empty + shift @segments; + + my ($obj,$view) = (pop(@segments) =~ m/(.*?)(?:\.(\w+))?$/); + push @segments, $obj; + + } + + return @segments; +} + + sub Invoke { my ($this,$action) = @_; - my $query = $action->query; - - my $method = $query->request_method; - - #TODO: path_info is broken for IIS - my $pathInfo = $query->path_info; - my @segments; - - if (length $pathInfo) { + my $method = $action->requestMethod; - @segments = split /\//, $pathInfo, -1; # keep trailing empty string if present - - # remove first segment since it's always empty - shift @segments; - - my ($obj,$view) = (pop(@segments) =~ m/(.*?)(?:\.(\w+))?$/); - push @segments, $obj; + my @segments = $this->GetResourcePath($action); - } - - - my $res = $this->contract->Transform($this->root, { id => '' } ); + my $res = $this->rootResource; while(@segments) { my $id = shift @segments; - $res = $res->FetchChildResource($id,$action); + $res = $res->FetchChildResource($id); die NotFoundException->new($pathInfo,$id) unless $res; } - $res = $res->InvokeHttpMethod($method,$action); + $res = $res->InvokeHttpVerb($method,$action); } 1; @@ -75,32 +78,50 @@ =head1 NAME -C<IMPL::Web::Handler::RestController> - Транслирует запросы к ресурсам в вызовы методов. +C<IMPL::Web::Handler::RestController> - Обрабатывает C<HTTP> запрос передавая +его соответствующему ресурсу. =head1 SYNOPSIS -Использует контракты для преобразования стандартных C<REST> запросов в вызовы методов объектов. -C<$ENV{PATH_INFO}> используется как путь к нужному ресурсу у которого будет вызван метод указанный в запросе. +Используется в конфигурации приложения как элемент цепочки обработчиков. +Как правило располагается на самом верхнем уровне. + +=begin code xml + + <handlers type="ARRAY"> + <item type="IMPL::Web::Handler::RestController"> + <rootResource type="My::App::Web::RootResource"/> + </item> + <item type="IMPL::Web::Handler::JSONView" /> + <item type="IMPL::Web::Handler::SecureCookie" /> + <item type="IMPL::Web::Handler::ErrorHandler" /> + </handlers> + +=end code xml + =head1 DESCRIPTION -=head2 Resource model +Использует C<PATH_INFO> для определения нужного ресурса, затем предает +найденному ресурсу управление для обработки запроса. + +Если ресурс не найден, то возникает исключение C<IMPL::Web::NotFoundException>. -Ресурсы имеют иерархическую структуру, аналогичную файлам и каталогам, которая описывается контрактом, также -контрак описывает то, как должны обрабатываться методы C<HTTP> запроса, такие как C<GET> и C<POST>. - -За корректность реализации данных методов отвечает разработчик. +Для определения нужного ресурса контроллер разбивает C<PATH_INFO> на фрагменты +и использует каждый фрагмент для получения дочернего ресурса начиная с корневого. +Для чего используется метод +C<< IMPL::Web::Application::ResourceInterface->FetchChildResource($childId) >>. -Каждый ресурс представляет собой коллкецию вложенных ресурсов, путь указанный в C<HTTP> запросе разбивается на -части, затем каждый сегмент последовательно используется для поиска дочернего ресурса. При обработки -первого сегмента используется корневой ресурс. Корневой ресурс должен существовать всегда. +=head1 MEMEBERS -=head2 Contract +=head2 C<[get]rootResource> -Контрактом может быть любое преобразование которое определяет соответсвие между объектами приложения и -ресурсами, доступными через протокол C<HTTP>. +Корневой ресурс приложения, должен быть всегда и реализовывать интерфес ресурса +C<IMPL::Web::Application::ResourceInterface>. +=head2 C<[get]trailingSlash> - +Если данная переменная имеет значение C<true>, то слеш в конце пути к ресурсу +будет интерпретироваться, как дочерний ресурс с пустым идентификатором. =cut \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/TTView.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Handler/TTView.pm Sat Sep 29 02:34:47 2012 +0400 @@ -4,195 +4,211 @@ use List::Util qw(first); use IMPL::lang qw(:declare :constants); use IMPL::declare { - require => { - Factory => 'IMPL::Object::Factory' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - } + require => { + Factory => 'IMPL::Object::Factory', + HttpResponse => 'IMPL::Web::HttpResponse' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + ], + + props => [ + contentType => PROP_GET | PROP_OWNERSET, + contentCharset => PROP_GET | PROP_OWNERSET, + loader => PROP_GET | PROP_OWNERSET, + selectors => PROP_GET | PROP_LIST | PROP_OWNERSET, + defaultDocument => PROP_ALL, + indexResource => PROP_ALL, + _selectorsCache => PROP_ALL, + _classTemplates => PROP_ALL + ] }; -BEGIN { - public property contentType => PROP_GET | PROP_OWNERSET; - public property loader => PROP_GET | PROP_OWNERSET; - public property selectors => PROP_GET | PROP_LIST | PROP_OWNERSET; - public property defaultDocument => PROP_ALL; - public property indexResource => PROP_ALL; - private property _selectorsCache => PROP_ALL; - private property _classTemplates => PROP_ALL; -} +sub CTOR { + my ($this) = @_; -sub CTOR { - my ($this) = @_; - - $this->indexResource('index') unless $this->indexResource; + $this->indexResource('index') unless $this->indexResource; } sub Invoke { - my ($this,$action,$next) = @_; - - my $result = $next ? $next->($action) : undef; - - my $vars = { - data => $result, - action => $action, - app => $action->application, + my ( $this, $action, $next ) = @_; + + my $result = $next ? $next->($action) : undef; + + my $vars = { + data => $result, + action => $action, + app => $action->application, LoadFactory => sub { - my $class = shift; - - my $module = $class; - - $module =~ s/::/\//g; - $module .= ".pm"; - - require $module; - return Factory->new($class); + my $class = shift; + + my $module = $class; + + $module =~ s/::/\//g; + $module .= ".pm"; + + require $module; + return Factory->new($class); } - }; - - my $doc = $this->loader->document( - $this->SelectView($action,ref $result), - $vars + }; + + my $doc = + $this->loader->document( $this->SelectView( $action, ref $result ), + $vars ); + + return HttpResponse->new( + type => $this->contentType, + charset => $this->contentCharset, + body => $doc->Render($vars) ); - - $action->response->contentType($this->contentType); - - my $hout = $action->response->streamBody; - - print $hout $doc->Render($vars); } sub SelectView { - my ($this,$action,$class) = @_; - - my @path = split /\//, $action->query->path_info(), -1; - - shift @path; # remove always empty leading segment - - my $last = pop @path; - $last =~ s/\.\w+$//; - $last ||= $this->indexResource; - push @path,$last; - - $this->BuildCache unless $this->_selectorsCache; - my $cache = $this->_selectorsCache; - - @path = reverse @path; - - foreach my $subclass ( $class ? (_GetHierarchy($class), '-default') : '-plain') { - my @results; - push @results, { result => $this->_classTemplates->{$subclass}, level => 0 } if $this->_classTemplates->{$subclass}; - if ($cache->{$subclass}) { - my $alternatives = [ { selector => $cache->{$subclass}, immediate => 1 } ]; - $alternatives = $this->MatchAlternatives($_,$alternatives,\@results) foreach @path; - } - - if (@results) { - @results = sort { $b->{level} <=> $a->{level} } @results; - return (shift @results)->{result}; - } - } - - return $this->defaultDocument; + my ( $this, $action, $class ) = @_; + + my @path = split /\//, $action->query->path_info(), -1; + + shift @path; # remove always empty leading segment + + my $last = pop @path; + $last =~ s/\.\w+$//; + $last ||= $this->indexResource; + push @path, $last; + + $this->BuildCache unless $this->_selectorsCache; + my $cache = $this->_selectorsCache; + + @path = reverse @path; + + foreach + my $subclass ( $class ? ( _GetHierarchy($class), '-default' ) : '-plain' ) + { + my @results; + push @results, + { result => $this->_classTemplates->{$subclass}, level => 0 } + if $this->_classTemplates->{$subclass}; + if ( $cache->{$subclass} ) { + my $alternatives = + [ { selector => $cache->{$subclass}, immediate => 1 } ]; + $alternatives = + $this->MatchAlternatives( $_, $alternatives, \@results ) + foreach @path; + } + + if (@results) { + @results = sort { $b->{level} <=> $a->{level} } @results; + return ( shift @results )->{result}; + } + } + + return $this->defaultDocument; } sub _GetHierarchy { - my ($class) = @_; - return unless $class; - - no strict 'refs'; - - return $class, map { _GetHierarchy($_) } @{"${class}::ISA"}; + my ($class) = @_; + return unless $class; + + no strict 'refs'; + + return $class, map { _GetHierarchy($_) } @{"${class}::ISA"}; } sub BuildCache { - my ($this) = @_; - - my @selectors; - - my $cache = $this->_selectorsCache({}); - $this->_classTemplates({}); - - foreach my $selector ($this->selectors) { - if (not ref $selector) { - - my ($path,$data) = split(/\s*=>\s*/, $selector); - - my @path = split(/\s+/,$path); - - my $class; - - # if this selector has a class part - if ($path[$#path] =~ m/^\@(.*)/) { - $class = $1; - pop @path; - } else { - $class = '-default'; - } - - #if this selector has a path - if (@path) { - @path = reverse @path; - my $last = pop @path; - my $t = ( $cache->{$class} ||= {} ); - my $level = 1; - foreach my $prim (@path ) { - $t = ($t->{$prim}->{next} ||= {}); - $level ++; + my ($this) = @_; + + my @selectors; + + my $cache = $this->_selectorsCache( {} ); + $this->_classTemplates( {} ); + + foreach my $selector ( $this->selectors ) { + if ( not ref $selector ) { + + my ( $path, $data ) = split( /\s*=>\s*/, $selector ); + + my @path = split( /\s+/, $path ); + + my $class; + + # if this selector has a class part + if ( $path[$#path] =~ m/^\@(.*)/ ) { + $class = $1; + pop @path; + } + else { + $class = '-default'; + } + + #if this selector has a path + if (@path) { + @path = reverse @path; + my $last = pop @path; + my $t = ( $cache->{$class} ||= {} ); + my $level = 1; + foreach my $prim (@path) { + $t = ( $t->{$prim}->{next} ||= {} ); + $level++; } $t->{$last}->{level} = $level; - $t->{$last}->{data} = $data; - - } else { - # we dont have a selector, only class - - $this->_classTemplates->{$class} = $data; - } - - } - } + $t->{$last}->{data} = $data; + + } + else { + + # we dont have a selector, only class + + $this->_classTemplates->{$class} = $data; + } + + } + } } sub MatchAlternatives { - my ($this,$segment,$alternatives,$results) = @_; - + my ( $this, $segment, $alternatives, $results ) = @_; + my @next; - + foreach my $alt (@$alternatives) { - while (my ($selector,$match) = each %{$alt->{selector}} ) { - - + while ( my ( $selector, $match ) = each %{ $alt->{selector} } ) { + my $context = { vars => \%{ $alt->{vars} || {} }, selector => $match->{next} }; - - if ($selector =~ s/^>//) { + + if ( $selector =~ s/^>// ) { $context->{immediate} = 1; } - - if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) { + + if ( my ( $name, $rx ) = + ( $selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) ) + { + #this is a regexp - - if ( my @captures = ($segment =~ m/($rx)/) ) { + + if ( my @captures = ( $segment =~ m/($rx)/ ) ) { $context->{success} = 1; - + if ($name) { $context->{vars}->{$name} = \@captures; } } - } else { + } + else { + #this is a segment name - if ($segment eq $selector) { + if ( $segment eq $selector ) { $context->{success} = 1; } } - + # test if there were a match - if (delete $context->{success}) { - if (my $data = $match->{data}) { + if ( delete $context->{success} ) { + if ( my $data = $match->{data} ) { + # interpolate data $data =~ s/{(\w+)(?:\:(\d+))?}/ my ($name,$index) = ($1,$2 || 0); @@ -203,20 +219,25 @@ ""; } /gex; - - push @$results, { level => $match->{level}, result => $data }; + + push @$results, + { level => $match->{level}, result => $data }; } push @next, $context if $context->{selector}; - } else { + } + else { + #repeat current alternative if it's not required to be immediate - push @next, { + push @next, + { selector => { $selector, $match }, - vars => $alt->{vars} - } unless $alt->{immediate}; + vars => $alt->{vars} + } + unless $alt->{immediate}; } } } - + return \@next; }
--- a/Lib/IMPL/Web/Handler/ViewSelector.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Handler/ViewSelector.pm Sat Sep 29 02:34:47 2012 +0400 @@ -4,67 +4,68 @@ use IMPL::lang qw(:declare :constants); use IMPL::declare { - require => { - NotAcceptable => 'IMPL::Web::NotAcceptableException', - ViewResult => 'IMPL::Web::Application::ViewResult' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - } + require => { + NotAcceptable => 'IMPL::Web::NotAcceptableException', + HttpResponse => 'IMPL::Web::HttpResponse' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + ], + props => [ + views => PROP_ALL | PROP_LIST, + fallback => PROP_ALL, + types => PROP_ALL + ] }; -BEGIN { - public property views => PROP_ALL | PROP_LIST; - public property fallback => PROP_ALL; - public property types => PROP_ALL; -} - sub Invoke { - my ($this,$action,$next) = @_; - - my $result = $next ? $next->($action) : undef; - - my $model; - - if( eval { $result->isa(ViewResult) } ) { - - my $handler; - my $path = $action->query->path_info; - - if ($this->types and $path =~ m/\.(\w+)$/) { - my $forced; - if ($forced = $this->types->{$1} and $action->query->Accept($forced) ) { - ($handler) = grep eval { $_->can('contentType') } && $_->contentType eq $forced, $this->views; - } - } - - if (not $handler) { - - my @handlers = - sort { - $b->{preference} <=> $a->{preference} - } map { - { - handler => $_, - preference => - eval { $_->can('contentType') } ? $action->query->Accept($_->contentType) : 0 - } - } $this->views; - - my $info = shift @handlers; - $handler = $info ? $info->{handler} : undef; - - } - - die NotAcceptable->new(map { eval {$_->can('contentType') } ? $_->contentType : () } $this->views ) - unless $handler; - - return $handler->Invoke($action,sub { $result }); - } else { - return $result; - } + my ( $this, $action, $next ) = @_; + + my $result = $next ? $next->($action) : undef; + + my $model; + + return $result if eval { $result->isa(HttpResponse) }; + + my $handler; + my $path = $action->pathInfo; + + if ( $this->types and $path =~ m/\.(\w+)$/ ) { + my $forced; + if ( $forced = $this->types->{$1} and $action->query->Accept($forced) ) + { + ($handler) = + grep eval { $_->can('contentType') } + && $_->contentType eq $forced, $this->views; + } + } + + if ( not $handler ) { + + my @handlers = + sort { $b->{preference} <=> $a->{preference} } map { + { + handler => $_, + preference => eval { $_->can('contentType') } + ? $action->query->Accept( $_->contentType ) + : 0 + } + } $this->views; + + my $info = shift @handlers; + $handler = $info ? $info->{handler} : undef; + + } + + die NotAcceptable->new( + map { + eval { $_->can('contentType') } ? $_->contentType : () + } $this->views + ) unless $handler; + + return $handler->Invoke( $action, sub { $result } ); } 1; @@ -96,4 +97,4 @@ Хеш с соотвествием между расширением и типом содержимого, для подсказки при выборе представления. -=cut \ No newline at end of file +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/HttpResponse.pm Sat Sep 29 02:34:47 2012 +0400 @@ -0,0 +1,139 @@ +use strict; +package IMPL::Web::HttpResponse; + +use CGI(); +use IMPL::lang qw(:declare); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgumentException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_' + ], + props => [ + status => PROP_ALL, + type => PROP_ALL, + charset => PROP_ALL, + cookies => PROP_ALL, + headers => PROP_ALL, + body => PROP_ALL + ] +}; + +sub CTOR { + my ($this) = @_; + + $this->headers({}) unless $this->headers(); + $this->cookies({}) unless $this->cookies(); +} + +sub PrintResponse { + my ($this,$out) = @_; + + my $q = CGI->new({}); + + my %headers = %{$this->headers}; + + if(my $cookies = $this->cookies) { + $headers{-cookie} = [map _createCookie($_,$cookies->{$_}), keys %$cookies] if $cookies; + } + + $headers{'-status'} = $this->status || '200 OK'; + $headers{'-type'} = $this->type || 'text/html'; + + if(my $charset = $this->charset) { + $q->charset($charset); + binmode $out, ":encoding($charset)"; + } + + $q->header(\%headers); + + if(my $body = $this->body) { + if(ref $body eq 'CODE') { + $body->($out); + } else { + print $out $body; + } + } +} + +#used to map a pair name valie to a valid cookie object +sub _createCookie { + return UNIVERSAL::isa($_[1], 'CGI::Cookie') ? $_[1] : CGI::Cookie->new(-name => $_[0], -value => $_[1] ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Web::HttpResponse> - Результат обработки C<HTTP> запроса. + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Базовый класс для ответов приложения на C<HTTP> запрос. Каждый вид ответа, +например + +Данный объект используется для формирования и передачи данных C<HTTP> ответа +напрямую. Основными полями являются C<body> и C<status>. + +Кроме свойств относящихся непосредственно к самому C<HTTP> ответу, данный объект +может содержать свойства относящиеся к процессу обработки запроса, например +механизму формирования представления. + +=head1 MEMBERS + +=head2 C<[get,set]status> + +Статус который будет отправлен сервером клиенту, например, C<200 OK> или +C<204 No response>. Если не указан, то будет C<200 OK>. + +=head2 C<[get,set]type> + +Тип содержимого, которое будет передано клиенту, если не указано, будет +C<text/html>. + +=head2 C<[get,set]charset> + +Кодировка в которой будут переданны данные. Следует задавать если и только, если +передается текстовая информация. Если указана кодировка, то она будет +автоматически применена к потоку, который будет передан методу C<PrintResponse>. + +=head2 C<[get,set]cookies> + +Опционально. Ссылка на хеш с печеньками. + +=head2 C<[get,set]headers> + +Опционально. Ссылка на хеш с дополнительными полями заголовка ответа. Формат +имен полей как у модуля C<CGI>. + +=begin code + +$response->header->{custom_header} = "my value"; + +#will produce the following header + +Custom-header: my value + +=end code + +=head2 C<[get,set]body> + +Тело ответа. Может быть как простой скаляр, который будет приведен к строке и +выдан в поток вывода метода C<PrintResponse>. Также может быть ссылкой на +процедуру, в таком случае будет вызвана эта процедура и ей будет передан +первым параметром поток для вывода тела ответа. + +=head2 C<PrintResponse($outStream)> + +Формирует заголовок и выводит ответ сервера в указанный параметром поток. + +=cut \ No newline at end of file
--- a/Lib/IMPL/Web/NotAcceptableException.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/NotAcceptableException.pm Sat Sep 29 02:34:47 2012 +0400 @@ -7,8 +7,8 @@ } }; -sub code { - 406; +sub status { + "406 Not acceptable" } 1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Web/NotAllowedException.pm Sat Sep 29 02:34:47 2012 +0400 @@ -0,0 +1,28 @@ +package IMPL::Web::NotAllowedException; +use strict; + +use IMPL::lang qw(:constants); +use IMPL::declare { + base => [ + 'IMPL::Web::Exception' => sub { + my %args = @_; + $args{Message}; + } + ] +}; + +sub CTOR { + my %args = @_; + + $this->headers({ + allow => $args{allow} + }); +} + +sub status { + "405 Method Not Allowed" +} + +1; + +__END__ \ No newline at end of file