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 Exporter 'import';
   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.
 116 Use of these methods additionally adds an automatic HTTP code 405
 117 C<Method Not Allowed> response if none of the HTTP methods match for a given dispatch and
 118 also adds a dispatch rule for C<HEAD> if no C<HEAD> exists but a C<GET> does
 119 (in which case the C<HEAD> returns the C<GET> dispatch with an empty body.)
 120
 121 We also add support at the end of the chain for the OPTIONS method.
 122 This defaults to HTTP 200 OK + Allows http headers.
 123
 124 We also try to set correct HTTP headers such as C<Allows> as makes sense based
 125 on your dispatch chain.
 126
 127 The following dispatch chains are basically the same:
 128
 129     sub dispatch_request {
 130       sub (/get-http-methods) {
 131         GET { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }
 132       },
 133       sub(/get-classic) {
 134         sub (GET) { [200, ['Content-Type' => 'text/plain'], ['Hello World']] },
 135         sub (HEAD)  { [200, ['Content-Type' => 'text/plain'], []] },
 136         sub (OPTIONS)  {
 137           [200, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], []];
 138         },
 139         sub () {
 140           [405, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'],
 141            ['Method Not Allowed']]
 142         },
 143       }
 144     }
 145
 146 The idea here is less boilerplate to distract the reader from the main point of
 147 the code and also to encapsulate some best practices.
 148
 149 B<NOTE> You currently cannot mix http method style and prototype sub style in
 150 the same scope, as in the following example:
 151
 152     sub dispatch_request {
 153       sub (/get-head) {
 154         GET { ... }
 155         sub (HEAD) { ... }
 156       },
 157     }
 158
 159 If you try this our code will notice and issue a C<die>.  If you have a good use
 160 case please bring it to the authors.
 161
 162 =head2 EXPORTS
 163
 164 This automatically exports the following subroutines:
 165
 166     GET
 167     PUT
 168     POST
 169     HEAD
 170     DELETE
 171     OPTIONS
 172
 173 =head1 AUTHOR
 174
 175 See L<Web::Simple> for AUTHOR
 176
 177 =head1 CONTRIBUTORS
 178
 179 See L<Web::Simple> for CONTRIBUTORS
 180
 181 =head1 COPYRIGHT
 182
 183 See L<Web::Simple> for COPYRIGHT
 184
 185 =head1 LICENSE
 186
 187 See L<Web::Simple> for LICENSE
 188
 189 =cut
 190