Commit | Line | Data |
456dc2bb |
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 helps 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 | |