lib/Web/Dispatch/HTTPMethods.pm

   1 package Web::Dispatch::HTTPMethods;
   2
   3 use strictures 1;
   4 use Web::Dispatch::Predicates qw(match_method);
   5 use Scalar::Util qw(blessed);
   6 use base qw(Exporter);
   7
   8 our @EXPORT = qw(GET HEAD POST PUT DELETE OPTIONS);
   9
  10 sub HEAD(&;@) { method_helper(HEAD => @_) }
  11 sub GET(&;@) { method_helper(GET => @_) }
  12 sub POST(&;@) { method_helper(POST => @_) }
  13 sub PUT(&;@) { method_helper(PUT => @_) }
  14 sub DELETE(&;@) { method_helper(DELETE => @_) }
  15 sub OPTIONS(&;@) { method_helper(OPTIONS => @_) }
  16
  17 {
  18   package Web::Dispatch::HTTPMethods::Endpoint;
  19
  20   sub new { bless { map { $_=>0 } @EXPORT }, shift }
  21   sub hdrs { 'Content-Type' => 'text/plain' }
  22
  23   sub create_implicit_HEAD {
  24     my $self = shift;
  25     if($self->{GET} && not $self->{HEAD}) {
  26       $self->{HEAD} = sub { [ @{$self->{GET}->(@_)}[0,1], []] };
  27     }
  28   }
  29
  30   sub create_implicit_OPTIONS {
  31     my $self = shift;
  32     $self->{OPTIONS} = sub {
  33       [200, [$self->hdrs, Allow=>$self->allowed] , [] ];
  34     };
  35   }
  36
  37   sub allowed { join ',', grep { $_[0]->{$_} } @EXPORT }
  38
  39   sub to_app {
  40     my $self = shift;
  41     my $implicit_HEAD = $self->create_implicit_HEAD;
  42     my $implicit_OPTIONS = $self->create_implicit_OPTIONS;
  43
  44     return sub {
  45       my $env = shift;
  46       if($env->{REQUEST_METHOD} eq 'HEAD') {
  47         $implicit_HEAD->($env);
  48       } elsif($env->{REQUEST_METHOD} eq 'OPTIONS') {
  49         $implicit_OPTIONS->($env);
  50       } else {
  51         [405, [$self->hdrs, Allow=>$self->allowed] , ['Method Not Allowed'] ];
  52       }
  53     };
  54   }
  55 }
  56
  57 sub isa_endpoint {
  58   blessed($_[0]) &&
  59     $_[0]->isa('Web::Dispatch::HTTPMethods::Endpoint')
  60 }
  61
  62 sub endpoint_from { return $_[-1] }
  63 sub new_endpoint { Web::Dispatch::HTTPMethods::Endpoint->new(@_) }
  64
  65 sub method_helper {
  66   my $predicate = match_method(my $method = shift);
  67   my ($code, @following ) = @_;
  68   endpoint_from( my @dispatchers =
  69     scalar(@following) ? ($predicate, @_) : ($predicate, @_, new_endpoint)
  70    )->{$method} = $code;
  71
  72   die "Non HTTP Method dispatcher detected in HTTP Method scope"
  73    unless(isa_endpoint($dispatchers[-1]));
  74
  75   return @dispatchers;
  76 }
  77
  78
  79 1;
  80
  81 =head1 NAME
  82
  83 Web::Dispatch::HTTPMethods - Helpers to make RESTFul Dispatchers Easier
  84
  85 =head1 SYNOPSIS
  86
  87     package MyApp:WithHTTPMethods;
  88
  89     use Web::Simple;
  90     use Web::Dispatch::HTTPMethods;
  91
  92     sub as_text {
  93       [200, ['Content-Type' => 'text/plain'],
  94         [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ]
  95     }
  96
  97     sub dispatch_request {
  98       sub (/get) {
  99         GET { as_text(pop) }
 100       },
 101       sub (/get-head) {
 102         GET { as_text(pop) }
 103         HEAD { [204,[],[]] },
 104       },
 105       sub (/get-post-put) {
 106         GET { as_text(pop) }  ## NOTE: no commas separating http methods
 107         POST { as_text(pop) }
 108         PUT { as_text(pop) }
 109       },
 110     }
 111
 112 =head1 DESCRIPTION
 113
 114 Exports the most commonly used HTTP methods as subroutine helpers into your
 115 L<Web::Simple> based application.  Additionally adds an automatic HTTP code 405
 116 C<Method Not Allow> if none of the HTTP methods match for a given dispatch and
 117 also adds a dispatch rule for C<HEAD> if no C<HEAD> exists but a C<GET> does
 118 (in which case the C<HEAD> returns the C<GET> dispatch with an empty body.)
 119
 120 We also add at the end of the chain support for the OPTIONS method (if you do
 121 not add one yourself.  This defaults to http 200 ok + Allows http headers.
 122
 123 Also we try to set correct HTTP headers such as C<Allows> as makes sense based
 124 on your dispatch chain.
 125
 126 The following dispatch chains are basically the same:
 127
 128     sub dispatch_request {
 129       sub (/get-http-methods) {
 130         GET { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }
 131       },
 132       sub(/get-classic) {
 133         sub (GET) { [200, ['Content-Type' => 'text/plain'], ['Hello World']] },
 134         sub (HEAD)  { [200, ['Content-Type' => 'text/plain'], []] },
 135         sub (OPTIONS)  {
 136           [200, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], []];
 137         },
 138         sub () {
 139           [405, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'],
 140            ['Method Not Allowed']]
 141         },
 142       }
 143     }
 144
 145 The idea here is less boilerplate to distract the reader from the main point of
 146 the code and also to encapsulate some best practices.
 147
 148 B<NOTE> You currently cannot mix http method style and prototype sub style in
 149 the same scope, as in the following example:
 150
 151     sub dispatch_request {
 152       sub (/get-head) {
 153         GET { ... }
 154         sub (HEAD) { ... }
 155       },
 156     }
 157
 158 If you try this our code will notice and issue a C<die>.  If you have a good use
 159 case please bring it to the authors.
 160
 161 =head2 EXPORTS
 162
 163 This automatically exports the following subroutines:
 164
 165     GET
 166     PUT
 167     POST
 168     HEAD
 169     DELETE
 170     OPTIONS
 171
 172 =head1 AUTHOR
 173
 174 See L<Web::Simple> for AUTHOR
 175
 176 =head1 CONTRIBUTORS
 177
 178 See L<Web::Simple> for CONTRIBUTORS
 179
 180 =head1 COPYRIGHT
 181
 182 See L<Web::Simple> for COPYRIGHT
 183
 184 =head1 LICENSE
 185
 186 See L<Web::Simple> for LICENSE
 187
 188 =cut
 189