# sub (<spec>) {} becomes a dispatcher
# sub {} is a PSGI app and can be returned as is
# '<spec>' => sub {} becomes a dispatcher
- # $obj isa WD:Predicates::Proxy => sub { ... } - become a dispatcher
+ # $obj isa WD:Predicates::Matcher => sub { ... } - become a dispatcher
# $obj w/to_app method is a Plack::App-like thing - call it to get a PSGI app
#
--- /dev/null
+package Web::Dispatch::HTTPMethods;
+
+use strictures 1;
+use Web::Dispatch::Predicates qw(match_method);
+use Scalar::Util qw(blessed);
+use base qw(Exporter);
+
+our @EXPORT = qw(GET HEAD POST PUT DELETE OPTIONS);
+
+sub HEAD(&;@) { method_helper(HEAD => @_) }
+sub GET(&;@) { method_helper(GET => @_) }
+sub POST(&;@) { method_helper(POST => @_) }
+sub PUT(&;@) { method_helper(PUT => @_) }
+sub DELETE(&;@) { method_helper(DELETE => @_) }
+sub OPTIONS(&;@) { method_helper(OPTIONS => @_) }
+
+{
+ package Web::Dispatch::HTTPMethods::Endpoint;
+
+ sub new { bless { map { $_=>0 } @EXPORT }, shift }
+ sub hdrs { 'Content-Type' => 'text/plain' }
+
+ sub create_implicit_HEAD {
+ my $self = shift;
+ if($self->{GET} && not $self->{HEAD}) {
+ $self->{HEAD} = sub { [ @{$self->{GET}->(@_)}[0,1], []] };
+ }
+ }
+
+ sub create_implicit_OPTIONS {
+ my $self = shift;
+ $self->{OPTIONS} = sub {
+ [200, [$self->hdrs, Allow=>$self->allowed] , [] ];
+ };
+ }
+
+ sub allowed { join ',', grep { $_[0]->{$_} } @EXPORT }
+
+ sub to_app {
+ my $self = shift;
+ my $implicit_HEAD = $self->create_implicit_HEAD;
+ my $implicit_OPTIONS = $self->create_implicit_OPTIONS;
+
+ return sub {
+ my $env = shift;
+ if($env->{REQUEST_METHOD} eq 'HEAD') {
+ $implicit_HEAD->($env);
+ } elsif($env->{REQUEST_METHOD} eq 'OPTIONS') {
+ $implicit_OPTIONS->($env);
+ } else {
+ [405, [$self->hdrs, Allow=>$self->allowed] , ['Method Not Allowed'] ];
+ }
+ };
+ }
+}
+
+sub isa_endpoint {
+ blessed($_[0]) &&
+ $_[0]->isa('Web::Dispatch::HTTPMethods::Endpoint')
+}
+
+sub endpoint_from { return $_[-1] }
+sub new_endpoint { Web::Dispatch::HTTPMethods::Endpoint->new(@_) }
+
+sub method_helper {
+ my $predicate = match_method(my $method = shift);
+ my ($code, @following ) = @_;
+ endpoint_from( my @dispatchers =
+ scalar(@following) ? ($predicate, @_) : ($predicate, @_, new_endpoint)
+ )->{$method} = $code;
+
+ die "Non HTTP Method dispatcher detected in HTTP Method scope"
+ unless(isa_endpoint($dispatchers[-1]));
+
+ return @dispatchers;
+}
+
+
+1;
+
+=head1 NAME
+
+Web::Dispatch::HTTPMethods - Helpers to make RESTFul Dispatchers Easier
+
+=head1 SYNOPSIS
+
+ package MyApp:WithHTTPMethods;
+
+ use Web::Simple;
+ use Web::Dispatch::HTTPMethods;
+
+ sub as_text {
+ [200, ['Content-Type' => 'text/plain'],
+ [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ]
+ }
+
+ sub dispatch_request {
+ sub (/get) {
+ GET { as_text(pop) }
+ },
+ sub (/get-head) {
+ GET { as_text(pop) }
+ HEAD { [204,[],[]] },
+ },
+ sub (/get-post-put) {
+ GET { as_text(pop) } ## NOTE: no commas separating http methods
+ POST { as_text(pop) }
+ PUT { as_text(pop) }
+ },
+ }
+
+=head1 DESCRIPTION
+
+Exports the most commonly used HTTP methods as subroutine helps into your
+L<Web::Simple> based application. Additionally adds an automatic HTTP code 405
+C<Method Not Allow> if none of the HTTP methods match for a given dispatch and
+also adds a dispatch rule for C<HEAD> if no C<HEAD> exists but a C<GET> does
+(in which case the C<HEAD> returns the C<GET> dispatch with an empty body.)
+
+We also add at the end of the chain support for the OPTIONS method (if you do
+not add one yourself. This defaults to http 200 ok + Allows http headers.
+
+Also we try to set correct HTTP headers such as C<Allows> as makes sense based
+on your dispatch chain.
+
+The following dispatch chains are basically the same:
+
+ sub dispatch_request {
+ sub (/get-http-methods) {
+ GET { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }
+ },
+ sub(/get-classic) {
+ sub (GET) { [200, ['Content-Type' => 'text/plain'], ['Hello World']] },
+ sub (HEAD) { [200, ['Content-Type' => 'text/plain'], []] },
+ sub (OPTIONS) {
+ [200, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], []];
+ },
+ sub () {
+ [405, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'],
+ ['Method Not Allowed']]
+ },
+ }
+ }
+
+The idea here is less boilerplate to distract the reader from the main point of
+the code and also to encapsulate some best practices.
+
+B<NOTE> You currently cannot mix http method style and prototype sub style in
+the same scope, as in the following example:
+
+ sub dispatch_request {
+ sub (/get-head) {
+ GET { ... }
+ sub (HEAD) { ... }
+ },
+ }
+
+If you try this our code will notice and issue a C<die>. If you have a good use
+case please bring it to the authors.
+
+=head2 EXPORTS
+
+This automatically exports the following subroutines:
+
+ GET
+ PUT
+ POST
+ HEAD
+ DELETE
+ OPTIONS
+
+=head1 AUTHOR
+
+See L<Web::Simple> for AUTHOR
+
+=head1 CONTRIBUTORS
+
+See L<Web::Simple> for CONTRIBUTORS
+
+=head1 COPYRIGHT
+
+See L<Web::Simple> for COPYRIGHT
+
+=head1 LICENSE
+
+See L<Web::Simple> for LICENSE
+
+=cut
+
match_extension match_query match_body match_uploads
);
-sub _generate_proxy { bless shift, 'Web::Dispatch::Matcher' }
+sub _matcher { bless shift, 'Web::Dispatch::Matcher' }
sub match_and {
my @match = @_;
- _generate_proxy(sub {
+ _matcher(sub {
my ($env) = @_;
my $my_env = { 'Web::Dispatch.original_env' => $env, %$env };
my $new_env;
sub match_or {
my @match = @_;
- _generate_proxy(sub {
+ _matcher(sub {
foreach my $try (@match) {
if (my @ret = $try->(@_)) {
return @ret;
sub match_not {
my ($match) = @_;
- _generate_proxy(sub {
+ _matcher(sub {
if (my @discard = $match->($_[0])) {
();
} else {
sub match_method {
my ($method) = @_;
- _generate_proxy(sub {
+ _matcher(sub {
my ($env) = @_;
$env->{REQUEST_METHOD} eq $method ? {} : ()
})
sub match_path {
my ($re) = @_;
- _generate_proxy(sub {
+ _matcher(sub {
my ($env) = @_;
if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
$cap[0] = {}; return @cap;
sub match_path_strip {
my ($re) = @_;
- _generate_proxy(sub {
+ _matcher(sub {
my ($env) = @_;
if (my @cap = ($env->{PATH_INFO} =~ /$re/)) {
$cap[0] = {
my $re = $wild
? qr/\.(\w+)$/
: qr/\.(\Q${extension}\E)$/;
- _generate_proxy(sub {
+ _matcher(sub {
if ($_[0]->{PATH_INFO} =~ $re) {
($wild ? ({}, $1) : {});
} else {
}
sub match_query {
- _generate_proxy(_param_matcher(query => $_[0]));
+ _matcher(_param_matcher(query => $_[0]));
}
sub match_body {
- _generate_proxy(_param_matcher(body => $_[0]));
+ _matcher(_param_matcher(body => $_[0]));
}
sub match_uploads {
- _generate_proxy(_param_matcher(uploads => $_[0]));
+ _matcher(_param_matcher(uploads => $_[0]));
}
sub _param_matcher {
--- /dev/null
+use strictures 1;
+use Test::More;
+
+{
+ package t::Web::Simple::HTTPMethods;
+
+ use Web::Simple;
+ use Web::Dispatch::HTTPMethods;
+
+ sub as_text {
+ [200, ['Content-Type' => 'text/plain'],
+ [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ]
+ }
+
+ sub dispatch_request {
+ sub (/get) {
+ GET { as_text(pop) }
+ },
+ sub (/get-head-options) {
+ GET { as_text(pop) }
+ HEAD { [204,[],[]] }
+ OPTIONS { [204,[],[]] },
+ },
+ sub (/get-post-put) {
+ GET { as_text(pop) }
+ POST { as_text(pop) }
+ PUT { as_text(pop) }
+ },
+ }
+}
+
+ok my $app = t::Web::Simple::HTTPMethods->new,
+ 'made app';
+
+for my $uri ('http://localhost/get-post-put') {
+
+ ## Check allowed methods and responses
+ for(ok my $res = $app->run_test_request(GET => $uri)) {
+ is $res->content, 'GET/get-post-put';
+ }
+
+ for(ok my $res = $app->run_test_request(POST => $uri)) {
+ is $res->content, 'POST/get-post-put';
+ }
+
+ for(ok my $res = $app->run_test_request(PUT => $uri)) {
+ is $res->content, 'PUT/get-post-put';
+ }
+
+ ## Since GET is allowed, check for implict HEAD
+ for(ok my $head = $app->run_test_request(HEAD => $uri)) {
+ is $head->code, 200;
+ is $head->content, '';
+ }
+
+ ## Check the implicit support for OPTIONS
+ for(ok my $options = $app->run_test_request(OPTIONS => $uri)) {
+ is $options->code, 200;
+ is $options->content, '';
+ is $options->header('Allow'), 'GET,HEAD,POST,PUT,OPTIONS';
+ }
+
+ ## Check implicitly added not allowed
+ for(ok my $not_allowed = $app->run_test_request(DELETE => $uri)) {
+ is $not_allowed->code, 405;
+ is $not_allowed->content, 'Method Not Allowed';
+ is $not_allowed->header('Allow'), 'GET,HEAD,POST,PUT,OPTIONS';
+ }
+
+}
+
+for my $uri ('http://localhost/get-head-options') {
+
+ ## Check allowed methods and responses
+ for(ok my $res = $app->run_test_request(GET => $uri)) {
+ is $res->content, 'GET/get-head-options';
+ }
+
+ for(ok my $head = $app->run_test_request(HEAD => $uri)) {
+ is $head->code, 204;
+ is $head->content, '';
+ }
+
+ for(ok my $options = $app->run_test_request(OPTIONS => $uri)) {
+ is $options->code, 204;
+ is $options->content, '';
+ }
+
+ ## Check implicitly added not allowed
+ for(ok my $not_allowed = $app->run_test_request(PUT => $uri)) {
+ is $not_allowed->code, 405;
+ is $not_allowed->content, 'Method Not Allowed';
+ is $not_allowed->header('Allow'), 'GET,HEAD,OPTIONS';
+ }
+
+}
+
+for my $uri ('http://localhost/get') {
+
+ ## Check allowed methods and responses
+ for(ok my $res = $app->run_test_request(GET => $uri)) {
+ is $res->content, 'GET/get';
+ }
+
+ ## Check implicitly added not allowed
+ for(ok my $not_allowed = $app->run_test_request(PUT => $uri)) {
+ is $not_allowed->code, 405;
+ is $not_allowed->content, 'Method Not Allowed';
+ is $not_allowed->header('Allow'), 'GET,HEAD,OPTIONS';
+ }
+
+ ## Since GET is allowed, check for implict HEAD
+ for(ok my $head = $app->run_test_request(HEAD => $uri)) {
+ is $head->code, 200;
+ is $head->content, '';
+ }
+
+}
+
+done_testing;
projects / catagits/Web-Simple.git / commitdiff