| line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
|
1
|
|
|
|
|
|
|
package PAGI::Response; |
|
2
|
|
|
|
|
|
|
|
|
3
|
7
|
|
|
7
|
|
367081
|
use strict; |
|
|
7
|
|
|
|
|
10
|
|
|
|
7
|
|
|
|
|
247
|
|
|
4
|
7
|
|
|
7
|
|
34
|
use warnings; |
|
|
7
|
|
|
|
|
9
|
|
|
|
7
|
|
|
|
|
297
|
|
|
5
|
|
|
|
|
|
|
|
|
6
|
7
|
|
|
7
|
|
28
|
use Future::AsyncAwait; |
|
|
7
|
|
|
|
|
10
|
|
|
|
7
|
|
|
|
|
49
|
|
|
7
|
7
|
|
|
7
|
|
315
|
use Carp qw(croak); |
|
|
7
|
|
|
|
|
10
|
|
|
|
7
|
|
|
|
|
360
|
|
|
8
|
7
|
|
|
7
|
|
505
|
use Encode qw(encode FB_CROAK); |
|
|
7
|
|
|
|
|
16297
|
|
|
|
7
|
|
|
|
|
335
|
|
|
9
|
7
|
|
|
7
|
|
741
|
use JSON::MaybeXS (); |
|
|
7
|
|
|
|
|
22199
|
|
|
|
7
|
|
|
|
|
26662
|
|
|
10
|
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 NAME |
|
13
|
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
PAGI::Response - Fluent response builder for PAGI applications |
|
15
|
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 SYNOPSIS |
|
17
|
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
use PAGI::Response; |
|
19
|
|
|
|
|
|
|
use Future::AsyncAwait; |
|
20
|
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# Basic usage in a raw PAGI app |
|
22
|
|
|
|
|
|
|
async sub app ($scope, $receive, $send) { |
|
23
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
24
|
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# Fluent chaining - set status, headers, then send |
|
26
|
|
|
|
|
|
|
await $res->status(200) |
|
27
|
|
|
|
|
|
|
->header('X-Custom' => 'value') |
|
28
|
|
|
|
|
|
|
->json({ message => 'Hello' }); |
|
29
|
|
|
|
|
|
|
} |
|
30
|
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# Various response types |
|
32
|
|
|
|
|
|
|
await $res->text("Hello World"); |
|
33
|
|
|
|
|
|
|
await $res->html("Hello"); |
|
34
|
|
|
|
|
|
|
await $res->json({ data => 'value' }); |
|
35
|
|
|
|
|
|
|
await $res->redirect('/login'); |
|
36
|
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# Streaming large responses |
|
38
|
|
|
|
|
|
|
await $res->stream(async sub ($writer) { |
|
39
|
|
|
|
|
|
|
await $writer->write("chunk1"); |
|
40
|
|
|
|
|
|
|
await $writer->write("chunk2"); |
|
41
|
|
|
|
|
|
|
await $writer->close(); |
|
42
|
|
|
|
|
|
|
}); |
|
43
|
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
# File downloads |
|
45
|
|
|
|
|
|
|
await $res->send_file('/path/to/file.pdf', filename => 'doc.pdf'); |
|
46
|
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
=head1 DESCRIPTION |
|
48
|
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
PAGI::Response provides a fluent interface for building HTTP responses in |
|
50
|
|
|
|
|
|
|
raw PAGI applications. It wraps the low-level C<$send> callback and provides |
|
51
|
|
|
|
|
|
|
convenient methods for common response types. |
|
52
|
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
B (C, C |
|
54
|
|
|
|
|
|
|
return C<$self> for fluent chaining. |
|
55
|
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
B (C, C, C, C, etc.) return |
|
57
|
|
|
|
|
|
|
Futures and actually send the response. Once a finisher is called, the |
|
58
|
|
|
|
|
|
|
response is sent and cannot be modified. |
|
59
|
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
B Each PAGI::Response instance can only send one response. |
|
61
|
|
|
|
|
|
|
Attempting to call a finisher method twice will throw an error. |
|
62
|
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
|
64
|
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=head2 new |
|
66
|
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
68
|
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
Creates a new response builder. |
|
70
|
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
=over 4 |
|
72
|
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=item C<$send> - Required. The PAGI send callback (coderef). |
|
74
|
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
=item C<$scope> - Required. The PAGI scope hashref. |
|
76
|
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=back |
|
78
|
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
The scope is required because PAGI::Response stores the "response sent" flag |
|
80
|
|
|
|
|
|
|
in C<< $scope->{'pagi.response.sent'} >>. This ensures that if multiple |
|
81
|
|
|
|
|
|
|
Response objects are created from the same scope (e.g., in middleware chains), |
|
82
|
|
|
|
|
|
|
they all share the same "sent" state and prevent double-sending responses. |
|
83
|
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
B Per-object state like C and C is NOT shared between |
|
85
|
|
|
|
|
|
|
Response objects. Only the "sent" flag is shared via scope. This matches the |
|
86
|
|
|
|
|
|
|
ASGI pattern where middleware wraps the C<$send> callable to intercept/modify |
|
87
|
|
|
|
|
|
|
responses, and Response objects build their own status/headers before sending. |
|
88
|
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=head1 CHAINABLE METHODS |
|
90
|
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
These methods return C<$self> for fluent chaining. |
|
92
|
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=head2 status |
|
94
|
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
$res->status(404); |
|
96
|
|
|
|
|
|
|
my $code = $res->status; |
|
97
|
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
Set or get the HTTP status code (100-599). Returns C<$self> when setting |
|
99
|
|
|
|
|
|
|
for fluent chaining. When getting, returns 200 if no status has been set. |
|
100
|
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
102
|
|
|
|
|
|
|
$res->status; # 200 (default, nothing set yet) |
|
103
|
|
|
|
|
|
|
$res->has_status; # false |
|
104
|
|
|
|
|
|
|
$res->status(201); # set explicitly |
|
105
|
|
|
|
|
|
|
$res->has_status; # true |
|
106
|
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=head2 status_try |
|
108
|
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
$res->status_try(404); |
|
110
|
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
Set the HTTP status code only if one hasn't been set yet. Useful in |
|
112
|
|
|
|
|
|
|
middleware or error handlers to provide fallback status codes without |
|
113
|
|
|
|
|
|
|
overriding choices made by the application: |
|
114
|
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
$res->status_try(202); # sets to 202 (nothing was set) |
|
116
|
|
|
|
|
|
|
$res->status_try(500); # no-op, 202 already set |
|
117
|
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
=head2 header |
|
119
|
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
$res->header('X-Custom' => 'value'); |
|
121
|
|
|
|
|
|
|
my $value = $res->header('X-Custom'); |
|
122
|
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
Add a response header. Can be called multiple times to add multiple headers. |
|
124
|
|
|
|
|
|
|
If called with only a name, returns the last value for that header or C. |
|
125
|
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
=head2 headers |
|
127
|
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
my $headers = $res->headers; |
|
129
|
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
Returns the full header arrayref C<[ name, value ]> in order. |
|
131
|
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=head2 header_all |
|
133
|
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
my @values = $res->header_all('Set-Cookie'); |
|
135
|
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
Returns all values for the given header name (case-insensitive). |
|
137
|
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
=head2 header_try |
|
139
|
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
$res->header_try('X-Custom' => 'value'); |
|
141
|
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
Add a response header only if that header name has not already been set. |
|
143
|
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=head2 content_type |
|
145
|
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
$res->content_type('text/html; charset=utf-8'); |
|
147
|
|
|
|
|
|
|
my $type = $res->content_type; |
|
148
|
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
Set the Content-Type header, replacing any existing one. |
|
150
|
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=head2 content_type_try |
|
152
|
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
$res->content_type_try('text/html; charset=utf-8'); |
|
154
|
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
Set the Content-Type header only if it has not already been set. |
|
156
|
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=head2 cookie |
|
158
|
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
$res->cookie('session' => 'abc123', |
|
160
|
|
|
|
|
|
|
max_age => 3600, |
|
161
|
|
|
|
|
|
|
path => '/', |
|
162
|
|
|
|
|
|
|
domain => 'example.com', |
|
163
|
|
|
|
|
|
|
secure => 1, |
|
164
|
|
|
|
|
|
|
httponly => 1, |
|
165
|
|
|
|
|
|
|
samesite => 'Strict', |
|
166
|
|
|
|
|
|
|
); |
|
167
|
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
Set a response cookie. Options: max_age, expires, path, domain, secure, |
|
169
|
|
|
|
|
|
|
httponly, samesite. |
|
170
|
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=head2 delete_cookie |
|
172
|
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
$res->delete_cookie('session'); |
|
174
|
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
Delete a cookie by setting it with Max-Age=0. |
|
176
|
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=head2 stash |
|
178
|
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
my $user = $res->stash->{user}; |
|
180
|
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
Returns the per-request stash hashref. This is the same stash accessible via |
|
182
|
|
|
|
|
|
|
C<< $req->stash >>, C<< $ws->stash >>, and C<< $sse->stash >> - it lives in |
|
183
|
|
|
|
|
|
|
C<< $scope->{'pagi.stash'} >> and is shared across all objects in the request |
|
184
|
|
|
|
|
|
|
chain. |
|
185
|
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
This allows handlers to read values set by middleware: |
|
187
|
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
async sub handler { |
|
189
|
|
|
|
|
|
|
my ($self, $req, $res) = @_; |
|
190
|
|
|
|
|
|
|
my $user = $res->stash->{user}; # Set by auth middleware |
|
191
|
|
|
|
|
|
|
await $res->json({ greeting => "Hello, $user->{name}" }); |
|
192
|
|
|
|
|
|
|
} |
|
193
|
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
See L for detailed documentation on how stash works. |
|
195
|
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=head2 is_sent |
|
197
|
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
if ($res->is_sent) { |
|
199
|
|
|
|
|
|
|
warn "Response already sent, cannot send error"; |
|
200
|
|
|
|
|
|
|
return; |
|
201
|
|
|
|
|
|
|
} |
|
202
|
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
Returns true if the response has already been finalized (sent to the client). |
|
204
|
|
|
|
|
|
|
Useful in error handlers or middleware that need to check whether they can |
|
205
|
|
|
|
|
|
|
still send a response. |
|
206
|
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
=head2 has_status |
|
208
|
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
if ($res->has_status) { ... } |
|
210
|
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
Returns true if a status code has been explicitly set via C or |
|
212
|
|
|
|
|
|
|
C. |
|
213
|
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=head2 has_header |
|
215
|
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
if ($res->has_header('content-type')) { ... } |
|
217
|
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
Returns true if the given header name has been set via C |
|
219
|
|
|
|
|
|
|
C. Header names are case-insensitive. |
|
220
|
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
=head2 has_content_type |
|
222
|
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
if ($res->has_content_type) { ... } |
|
224
|
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
Returns true if Content-Type has been explicitly set via C, |
|
226
|
|
|
|
|
|
|
C, or C/C with a Content-Type name. |
|
227
|
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
=head2 cors |
|
229
|
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
# Allow all origins (simplest case) |
|
231
|
|
|
|
|
|
|
$res->cors->json({ data => 'value' }); |
|
232
|
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# Allow specific origin |
|
234
|
|
|
|
|
|
|
$res->cors(origin => 'https://example.com')->json($data); |
|
235
|
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# Full configuration |
|
237
|
|
|
|
|
|
|
$res->cors( |
|
238
|
|
|
|
|
|
|
origin => 'https://example.com', |
|
239
|
|
|
|
|
|
|
methods => [qw(GET POST PUT DELETE)], |
|
240
|
|
|
|
|
|
|
headers => [qw(Content-Type Authorization)], |
|
241
|
|
|
|
|
|
|
expose => [qw(X-Request-Id X-RateLimit-Remaining)], |
|
242
|
|
|
|
|
|
|
credentials => 1, |
|
243
|
|
|
|
|
|
|
max_age => 86400, |
|
244
|
|
|
|
|
|
|
preflight => 0, |
|
245
|
|
|
|
|
|
|
)->json($data); |
|
246
|
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
Add CORS (Cross-Origin Resource Sharing) headers to the response. |
|
248
|
|
|
|
|
|
|
Returns C<$self> for chaining. |
|
249
|
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
B |
|
251
|
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
=over 4 |
|
253
|
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=item * C - Allowed origin. Default: C<'*'> (all origins). |
|
255
|
|
|
|
|
|
|
Can be a specific origin like C<'https://example.com'> or C<'*'> for any. |
|
256
|
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=item * C - Arrayref of allowed HTTP methods for preflight. |
|
258
|
|
|
|
|
|
|
Default: C<[qw(GET POST PUT DELETE PATCH OPTIONS)]>. |
|
259
|
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
=item * C - Arrayref of allowed request headers for preflight. |
|
261
|
|
|
|
|
|
|
Default: C<[qw(Content-Type Authorization X-Requested-With)]>. |
|
262
|
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=item * C - Arrayref of response headers to expose to the client. |
|
264
|
|
|
|
|
|
|
By default, only simple headers (Cache-Control, Content-Language, etc.) |
|
265
|
|
|
|
|
|
|
are accessible. Use this to expose custom headers. |
|
266
|
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=item * C - Boolean. If true, sets |
|
268
|
|
|
|
|
|
|
C, allowing cookies and |
|
269
|
|
|
|
|
|
|
Authorization headers. Default: C<0>. |
|
270
|
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
=item * C - How long (in seconds) browsers should cache preflight |
|
272
|
|
|
|
|
|
|
results. Default: C<86400> (24 hours). |
|
273
|
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
=item * C - Boolean. If true, includes preflight response headers |
|
275
|
|
|
|
|
|
|
(Allow-Methods, Allow-Headers, Max-Age). Set this when handling OPTIONS |
|
276
|
|
|
|
|
|
|
requests. Default: C<0>. |
|
277
|
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
=item * C - The Origin header value from the request. |
|
279
|
|
|
|
|
|
|
Required when C is true and C is C<'*'>, because |
|
280
|
|
|
|
|
|
|
the CORS spec forbids using C<'*'> with credentials. Pass the actual |
|
281
|
|
|
|
|
|
|
request origin to echo it back. |
|
282
|
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
=back |
|
284
|
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
B |
|
286
|
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=over 4 |
|
288
|
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=item * When C is true, you cannot use C<< origin => '*' >>. |
|
290
|
|
|
|
|
|
|
Either specify an exact origin, or pass C with the |
|
291
|
|
|
|
|
|
|
client's actual Origin header. |
|
292
|
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
=item * The C header is always set to ensure proper caching |
|
294
|
|
|
|
|
|
|
when origin-specific responses are used. |
|
295
|
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
=item * For preflight (OPTIONS) requests, set C<< preflight => 1 >> and |
|
297
|
|
|
|
|
|
|
typically respond with C<< $res->status(204)->empty() >>. |
|
298
|
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
=back |
|
300
|
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
=head1 FINISHER METHODS |
|
302
|
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
These methods return Futures and send the response. |
|
304
|
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
=head2 text |
|
306
|
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
await $res->text("Hello World"); |
|
308
|
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
Send a plain text response with Content-Type: text/plain; charset=utf-8. |
|
310
|
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
=head2 html |
|
312
|
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
await $res->html("Hello"); |
|
314
|
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
Send an HTML response with Content-Type: text/html; charset=utf-8. |
|
316
|
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=head2 json |
|
318
|
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
await $res->json({ message => 'Hello' }); |
|
320
|
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
Send a JSON response with Content-Type: application/json; charset=utf-8. |
|
322
|
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
=head2 redirect |
|
324
|
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
await $res->redirect('/login'); |
|
326
|
|
|
|
|
|
|
await $res->redirect('/new-url', 301); |
|
327
|
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
Send a redirect response with an empty body. Default status is 302. |
|
329
|
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
B This method sends the response but does NOT stop Perl execution. |
|
331
|
|
|
|
|
|
|
Use C after redirect if you have more code below: |
|
332
|
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
await $res->redirect('/login'); |
|
334
|
|
|
|
|
|
|
return; # Important! Code below would still run otherwise |
|
335
|
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
B While RFC 7231 suggests including a short HTML body with a |
|
337
|
|
|
|
|
|
|
hyperlink for clients that don't auto-follow redirects, all modern browsers |
|
338
|
|
|
|
|
|
|
and HTTP clients ignore redirect bodies. If you need a body for legacy |
|
339
|
|
|
|
|
|
|
compatibility, use the lower-level C<$send-E()> calls directly. |
|
340
|
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
=head2 empty |
|
342
|
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
await $res->empty(); |
|
344
|
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
Send an empty response with status 204 No Content (or custom status if set). |
|
346
|
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
=head2 send |
|
348
|
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
await $res->send($text); |
|
350
|
|
|
|
|
|
|
await $res->send($text, charset => 'iso-8859-1'); |
|
351
|
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
Send text, encoding it to UTF-8 (or specified charset). Adds charset to |
|
353
|
|
|
|
|
|
|
Content-Type if not present. This is the high-level method for sending |
|
354
|
|
|
|
|
|
|
text responses. |
|
355
|
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
=head2 send_raw |
|
357
|
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
await $res->send_raw($bytes); |
|
359
|
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
Send raw bytes as the response body without any encoding. Use this for |
|
361
|
|
|
|
|
|
|
binary data or when you've already encoded the content yourself. |
|
362
|
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
=head2 stream |
|
364
|
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
await $res->stream(async sub ($writer) { |
|
366
|
|
|
|
|
|
|
await $writer->write("chunk1"); |
|
367
|
|
|
|
|
|
|
await $writer->write("chunk2"); |
|
368
|
|
|
|
|
|
|
await $writer->close(); |
|
369
|
|
|
|
|
|
|
}); |
|
370
|
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
Stream response chunks via callback. The callback receives a writer object |
|
372
|
|
|
|
|
|
|
with C, C, and C methods. |
|
373
|
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
=head2 send_file |
|
375
|
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
await $res->send_file('/path/to/file.pdf'); |
|
377
|
|
|
|
|
|
|
await $res->send_file('/path/to/file.pdf', |
|
378
|
|
|
|
|
|
|
filename => 'download.pdf', |
|
379
|
|
|
|
|
|
|
inline => 1, |
|
380
|
|
|
|
|
|
|
); |
|
381
|
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# Partial file (for range requests) |
|
383
|
|
|
|
|
|
|
await $res->send_file('/path/to/video.mp4', |
|
384
|
|
|
|
|
|
|
offset => 1024, # Start from byte 1024 |
|
385
|
|
|
|
|
|
|
length => 65536, # Send 64KB |
|
386
|
|
|
|
|
|
|
); |
|
387
|
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
Send a file as the response. This method uses the PAGI protocol's C |
|
389
|
|
|
|
|
|
|
key for efficient server-side streaming. The file is B read into memory. |
|
390
|
|
|
|
|
|
|
For production, use L to delegate file serving |
|
391
|
|
|
|
|
|
|
to your reverse proxy. |
|
392
|
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
B |
|
394
|
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
=over 4 |
|
396
|
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
=item * C - Set Content-Disposition attachment filename |
|
398
|
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
=item * C - Use Content-Disposition: inline instead of attachment |
|
400
|
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
=item * C - Start position in bytes (default: 0). For range requests. |
|
402
|
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
=item * C - Number of bytes to send. Defaults to file size minus offset. |
|
404
|
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
=back |
|
406
|
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
B |
|
408
|
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# Manual range request handling |
|
410
|
|
|
|
|
|
|
async sub handle_video ($req, $send) { |
|
411
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
412
|
|
|
|
|
|
|
my $path = '/videos/movie.mp4'; |
|
413
|
|
|
|
|
|
|
my $size = -s $path; |
|
414
|
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
my $range = $req->header('Range'); |
|
416
|
|
|
|
|
|
|
if ($range && $range =~ /bytes=(\d+)-(\d*)/) { |
|
417
|
|
|
|
|
|
|
my $start = $1; |
|
418
|
|
|
|
|
|
|
my $end = $2 || ($size - 1); |
|
419
|
|
|
|
|
|
|
my $length = $end - $start + 1; |
|
420
|
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
return await $res->status(206) |
|
422
|
|
|
|
|
|
|
->header('Content-Range' => "bytes $start-$end/$size") |
|
423
|
|
|
|
|
|
|
->header('Accept-Ranges' => 'bytes') |
|
424
|
|
|
|
|
|
|
->send_file($path, offset => $start, length => $length); |
|
425
|
|
|
|
|
|
|
} |
|
426
|
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
return await $res->header('Accept-Ranges' => 'bytes') |
|
428
|
|
|
|
|
|
|
->send_file($path); |
|
429
|
|
|
|
|
|
|
} |
|
430
|
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
B For production file serving with full features (ETag caching, |
|
432
|
|
|
|
|
|
|
automatic range request handling, conditional GETs, directory indexes), |
|
433
|
|
|
|
|
|
|
use L instead: |
|
434
|
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
use PAGI::App::File; |
|
436
|
|
|
|
|
|
|
my $files = PAGI::App::File->new(root => '/var/www/static'); |
|
437
|
|
|
|
|
|
|
my $app = $files->to_app; |
|
438
|
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
=head1 EXAMPLES |
|
440
|
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
=head2 Complete Raw PAGI Application |
|
442
|
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
use Future::AsyncAwait; |
|
444
|
|
|
|
|
|
|
use PAGI::Request; |
|
445
|
|
|
|
|
|
|
use PAGI::Response; |
|
446
|
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
my $app = async sub ($scope, $receive, $send) { |
|
448
|
|
|
|
|
|
|
return await handle_lifespan($scope, $receive, $send) |
|
449
|
|
|
|
|
|
|
if $scope->{type} eq 'lifespan'; |
|
450
|
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
my $req = PAGI::Request->new($scope, $receive); |
|
452
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
453
|
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
if ($req->method eq 'GET' && $req->path eq '/') { |
|
455
|
|
|
|
|
|
|
return await $res->html('Welcome'); |
|
456
|
|
|
|
|
|
|
} |
|
457
|
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
if ($req->method eq 'POST' && $req->path eq '/api/users') { |
|
459
|
|
|
|
|
|
|
my $data = await $req->json; |
|
460
|
|
|
|
|
|
|
# ... create user ... |
|
461
|
|
|
|
|
|
|
return await $res->status(201) |
|
462
|
|
|
|
|
|
|
->header('Location' => '/api/users/123') |
|
463
|
|
|
|
|
|
|
->json({ id => 123, name => $data->{name} }); |
|
464
|
|
|
|
|
|
|
} |
|
465
|
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
return await $res->status(404)->json({ error => 'Not Found' }); |
|
467
|
|
|
|
|
|
|
}; |
|
468
|
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
=head2 Form Validation with Error Response |
|
470
|
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
async sub handle_contact ($req, $send) { |
|
472
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
473
|
|
|
|
|
|
|
my $form = await $req->form_params; |
|
474
|
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
my @errors; |
|
476
|
|
|
|
|
|
|
my $email = $form->get('email') // ''; |
|
477
|
|
|
|
|
|
|
my $message = $form->get('message') // ''; |
|
478
|
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
push @errors, 'Email required' unless $email; |
|
480
|
|
|
|
|
|
|
push @errors, 'Invalid email' unless $email =~ /@/; |
|
481
|
|
|
|
|
|
|
push @errors, 'Message required' unless $message; |
|
482
|
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
if (@errors) { |
|
484
|
|
|
|
|
|
|
return await $res->status(422) |
|
485
|
|
|
|
|
|
|
->json({ error => 'Validation failed', errors => \@errors }); |
|
486
|
|
|
|
|
|
|
} |
|
487
|
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# Process valid form... |
|
489
|
|
|
|
|
|
|
return await $res->json({ success => 1 }); |
|
490
|
|
|
|
|
|
|
} |
|
491
|
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
=head2 Authentication with Cookies |
|
493
|
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
async sub handle_login ($req, $send) { |
|
495
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
496
|
|
|
|
|
|
|
my $data = await $req->json; |
|
497
|
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
my $user = authenticate($data->{email}, $data->{password}); |
|
499
|
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
unless ($user) { |
|
501
|
|
|
|
|
|
|
return await $res->status(401)->json({ error => 'Invalid credentials' }); |
|
502
|
|
|
|
|
|
|
} |
|
503
|
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
my $session_id = create_session($user); |
|
505
|
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
return await $res->cookie('session' => $session_id, |
|
507
|
|
|
|
|
|
|
path => '/', |
|
508
|
|
|
|
|
|
|
httponly => 1, |
|
509
|
|
|
|
|
|
|
secure => 1, |
|
510
|
|
|
|
|
|
|
samesite => 'Strict', |
|
511
|
|
|
|
|
|
|
max_age => 86400, # 24 hours |
|
512
|
|
|
|
|
|
|
) |
|
513
|
|
|
|
|
|
|
->json({ user => { id => $user->{id}, name => $user->{name} } }); |
|
514
|
|
|
|
|
|
|
} |
|
515
|
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
async sub handle_logout ($req, $send) { |
|
517
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
518
|
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
return await $res->delete_cookie('session', path => '/') |
|
520
|
|
|
|
|
|
|
->json({ logged_out => 1 }); |
|
521
|
|
|
|
|
|
|
} |
|
522
|
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
=head2 File Download |
|
524
|
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
async sub handle_download ($req, $send) { |
|
526
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
527
|
|
|
|
|
|
|
my $file_id = $req->path_param('id'); |
|
528
|
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
my $file = get_file($file_id); # Be sure to clean $file |
|
530
|
|
|
|
|
|
|
unless ($file && -f $file->{path}) { |
|
531
|
|
|
|
|
|
|
return await $res->status(404)->json({ error => 'File not found' }); |
|
532
|
|
|
|
|
|
|
} |
|
533
|
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
return await $res->send_file($file->{path}, |
|
535
|
|
|
|
|
|
|
filename => $file->{original_name}, |
|
536
|
|
|
|
|
|
|
); |
|
537
|
|
|
|
|
|
|
} |
|
538
|
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
=head2 Streaming Large Data |
|
540
|
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
async sub handle_export ($req, $send) { |
|
542
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
543
|
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
await $res->content_type('text/csv') |
|
545
|
|
|
|
|
|
|
->header('Content-Disposition' => 'attachment; filename="export.csv"') |
|
546
|
|
|
|
|
|
|
->stream(async sub ($writer) { |
|
547
|
|
|
|
|
|
|
# Write CSV header |
|
548
|
|
|
|
|
|
|
await $writer->write("id,name,email\n"); |
|
549
|
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# Stream rows from database |
|
551
|
|
|
|
|
|
|
my $cursor = get_all_users_cursor(); |
|
552
|
|
|
|
|
|
|
while (my $user = $cursor->next) { |
|
553
|
|
|
|
|
|
|
await $writer->write("$user->{id},$user->{name},$user->{email}\n"); |
|
554
|
|
|
|
|
|
|
} |
|
555
|
|
|
|
|
|
|
}); |
|
556
|
|
|
|
|
|
|
} |
|
557
|
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
=head2 Server-Sent Events Style Streaming |
|
559
|
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
async sub handle_events ($req, $send) { |
|
561
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
562
|
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
await $res->content_type('text/event-stream') |
|
564
|
|
|
|
|
|
|
->header('Cache-Control' => 'no-cache') |
|
565
|
|
|
|
|
|
|
->stream(async sub ($writer) { |
|
566
|
|
|
|
|
|
|
for my $i (1..10) { |
|
567
|
|
|
|
|
|
|
await $writer->write("data: Event $i\n\n"); |
|
568
|
|
|
|
|
|
|
await some_delay(1); # Wait 1 second |
|
569
|
|
|
|
|
|
|
} |
|
570
|
|
|
|
|
|
|
}); |
|
571
|
|
|
|
|
|
|
} |
|
572
|
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
=head2 Conditional Responses |
|
574
|
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
async sub handle_resource ($req, $send) { |
|
576
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
577
|
|
|
|
|
|
|
my $etag = '"abc123"'; |
|
578
|
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
# Check If-None-Match for caching |
|
580
|
|
|
|
|
|
|
my $if_none_match = $req->header('If-None-Match') // ''; |
|
581
|
|
|
|
|
|
|
if ($if_none_match eq $etag) { |
|
582
|
|
|
|
|
|
|
return await $res->status(304)->empty(); |
|
583
|
|
|
|
|
|
|
} |
|
584
|
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
return await $res->header('ETag' => $etag) |
|
586
|
|
|
|
|
|
|
->header('Cache-Control' => 'max-age=3600') |
|
587
|
|
|
|
|
|
|
->json({ data => 'expensive computation result' }); |
|
588
|
|
|
|
|
|
|
} |
|
589
|
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
=head2 CORS API Endpoint |
|
591
|
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
# Simple CORS - allow all origins |
|
593
|
|
|
|
|
|
|
async sub handle_api ($scope, $receive, $send) { |
|
594
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
595
|
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
return await $res->cors->json({ status => 'ok' }); |
|
597
|
|
|
|
|
|
|
} |
|
598
|
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
# CORS with credentials (e.g., cookies, auth headers) |
|
600
|
|
|
|
|
|
|
async sub handle_api_with_auth ($scope, $receive, $send) { |
|
601
|
|
|
|
|
|
|
my $req = PAGI::Request->new($scope, $receive); |
|
602
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
603
|
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
# Get the Origin header from request |
|
605
|
|
|
|
|
|
|
my $origin = $req->header('Origin'); |
|
606
|
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
return await $res->cors( |
|
608
|
|
|
|
|
|
|
origin => 'https://myapp.com', # Or use request_origin |
|
609
|
|
|
|
|
|
|
credentials => 1, |
|
610
|
|
|
|
|
|
|
expose => [qw(X-Request-Id)], |
|
611
|
|
|
|
|
|
|
)->json({ user => 'authenticated' }); |
|
612
|
|
|
|
|
|
|
} |
|
613
|
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
=head2 CORS Preflight Handler |
|
615
|
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
# Handle OPTIONS preflight requests |
|
617
|
|
|
|
|
|
|
async sub app ($scope, $receive, $send) { |
|
618
|
|
|
|
|
|
|
my $req = PAGI::Request->new($scope, $receive); |
|
619
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
620
|
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
# Handle preflight |
|
622
|
|
|
|
|
|
|
if ($req->method eq 'OPTIONS') { |
|
623
|
|
|
|
|
|
|
return await $res->cors( |
|
624
|
|
|
|
|
|
|
origin => 'https://myapp.com', |
|
625
|
|
|
|
|
|
|
methods => [qw(GET POST PUT DELETE)], |
|
626
|
|
|
|
|
|
|
headers => [qw(Content-Type Authorization X-Custom-Header)], |
|
627
|
|
|
|
|
|
|
credentials => 1, |
|
628
|
|
|
|
|
|
|
max_age => 86400, |
|
629
|
|
|
|
|
|
|
preflight => 1, # Include preflight headers |
|
630
|
|
|
|
|
|
|
)->status(204)->empty(); |
|
631
|
|
|
|
|
|
|
} |
|
632
|
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# Handle actual request |
|
634
|
|
|
|
|
|
|
return await $res->cors( |
|
635
|
|
|
|
|
|
|
origin => 'https://myapp.com', |
|
636
|
|
|
|
|
|
|
credentials => 1, |
|
637
|
|
|
|
|
|
|
)->json({ data => 'response' }); |
|
638
|
|
|
|
|
|
|
} |
|
639
|
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
=head2 Dynamic CORS Origin |
|
641
|
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
# Allow multiple origins dynamically |
|
643
|
|
|
|
|
|
|
my %ALLOWED_ORIGINS = map { $_ => 1 } qw( |
|
644
|
|
|
|
|
|
|
https://app1.example.com |
|
645
|
|
|
|
|
|
|
https://app2.example.com |
|
646
|
|
|
|
|
|
|
https://localhost:3000 |
|
647
|
|
|
|
|
|
|
); |
|
648
|
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
async sub handle_api ($scope, $receive, $send) { |
|
650
|
|
|
|
|
|
|
my $req = PAGI::Request->new($scope, $receive); |
|
651
|
|
|
|
|
|
|
my $res = PAGI::Response->new($scope, $send); |
|
652
|
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
my $request_origin = $req->header('Origin') // ''; |
|
654
|
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
# Check if origin is allowed |
|
656
|
|
|
|
|
|
|
if ($ALLOWED_ORIGINS{$request_origin}) { |
|
657
|
|
|
|
|
|
|
return await $res->cors( |
|
658
|
|
|
|
|
|
|
origin => $request_origin, # Echo back the allowed origin |
|
659
|
|
|
|
|
|
|
credentials => 1, |
|
660
|
|
|
|
|
|
|
)->json({ data => 'allowed' }); |
|
661
|
|
|
|
|
|
|
} |
|
662
|
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
# Origin not allowed - respond without CORS headers |
|
664
|
|
|
|
|
|
|
return await $res->status(403)->json({ error => 'Origin not allowed' }); |
|
665
|
|
|
|
|
|
|
} |
|
666
|
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
=head1 WRITER OBJECT |
|
668
|
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
The C method passes a writer object to its callback with these methods: |
|
670
|
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
=over 4 |
|
672
|
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
=item * C - Write a chunk (returns Future) |
|
674
|
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
=item * C - Close the stream (returns Future) |
|
676
|
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
=item * C - Get total bytes written so far |
|
678
|
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
=back |
|
680
|
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
The writer automatically closes when the callback completes, but calling |
|
682
|
|
|
|
|
|
|
C explicitly is recommended for clarity. |
|
683
|
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
=head1 ERROR HANDLING |
|
685
|
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
All finisher methods return Futures. Errors in encoding (e.g., invalid UTF-8 |
|
687
|
|
|
|
|
|
|
when C mode would be enabled) will cause the Future to fail. |
|
688
|
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
use Syntax::Keyword::Try; |
|
690
|
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
try { |
|
692
|
|
|
|
|
|
|
await $res->json($data); |
|
693
|
|
|
|
|
|
|
} |
|
694
|
|
|
|
|
|
|
catch ($e) { |
|
695
|
|
|
|
|
|
|
warn "Failed to send response: $e"; |
|
696
|
|
|
|
|
|
|
} |
|
697
|
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
=head1 SEE ALSO |
|
699
|
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
L, L, L |
|
701
|
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
=head1 AUTHOR |
|
703
|
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
PAGI Contributors |
|
705
|
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=cut |
|
707
|
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
sub new { |
|
709
|
87
|
|
|
87
|
1
|
435452
|
my ($class, $scope, $send) = @_; |
|
710
|
87
|
100
|
66
|
|
|
493
|
croak("scope is required") unless $scope && ref($scope) eq 'HASH'; |
|
711
|
86
|
100
|
|
|
|
238
|
croak("send is required") unless $send; |
|
712
|
85
|
100
|
|
|
|
339
|
croak("send must be a coderef") unless ref($send) eq 'CODE'; |
|
713
|
|
|
|
|
|
|
|
|
714
|
84
|
|
|
|
|
344
|
my $self = bless { |
|
715
|
|
|
|
|
|
|
send => $send, |
|
716
|
|
|
|
|
|
|
scope => $scope, |
|
717
|
|
|
|
|
|
|
# _status not set here - uses exists() check and lazy default of 200 |
|
718
|
|
|
|
|
|
|
_headers => [], |
|
719
|
|
|
|
|
|
|
_header_set => {}, |
|
720
|
|
|
|
|
|
|
}, $class; |
|
721
|
|
|
|
|
|
|
|
|
722
|
84
|
|
|
|
|
165
|
return $self; |
|
723
|
|
|
|
|
|
|
} |
|
724
|
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
sub status { |
|
726
|
78
|
|
|
78
|
1
|
1882
|
my ($self, $code) = @_; |
|
727
|
78
|
100
|
100
|
|
|
474
|
return $self->{_status} // 200 if @_ == 1; # lazy default |
|
728
|
16
|
100
|
100
|
|
|
485
|
croak("Status must be a number between 100-599") |
|
|
|
|
100
|
|
|
|
|
|
729
|
|
|
|
|
|
|
unless $code =~ /^\d+$/ && $code >= 100 && $code <= 599; |
|
730
|
13
|
|
|
|
|
31
|
$self->{_status} = $code; |
|
731
|
13
|
|
|
|
|
44
|
return $self; |
|
732
|
|
|
|
|
|
|
} |
|
733
|
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
sub status_try { |
|
735
|
2
|
|
|
2
|
1
|
4
|
my ($self, $code) = @_; |
|
736
|
2
|
100
|
|
|
|
5
|
return $self if exists $self->{_status}; |
|
737
|
1
|
|
|
|
|
3
|
return $self->status($code); |
|
738
|
|
|
|
|
|
|
} |
|
739
|
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
sub header { |
|
741
|
54
|
|
|
54
|
1
|
1276
|
my ($self, $name, $value) = @_; |
|
742
|
54
|
50
|
|
|
|
86
|
croak("Header name is required") unless defined $name; |
|
743
|
54
|
100
|
|
|
|
90
|
if (@_ == 2) { |
|
744
|
2
|
|
|
|
|
6
|
my $key = lc($name); |
|
745
|
2
|
|
|
|
|
2
|
for (my $i = $#{$self->{_headers}}; $i >= 0; $i--) { |
|
|
2
|
|
|
|
|
8
|
|
|
746
|
2
|
|
|
|
|
2
|
my $pair = $self->{_headers}[$i]; |
|
747
|
2
|
50
|
|
|
|
12
|
return $pair->[1] if lc($pair->[0]) eq $key; |
|
748
|
|
|
|
|
|
|
} |
|
749
|
0
|
|
|
|
|
0
|
return undef; |
|
750
|
|
|
|
|
|
|
} |
|
751
|
52
|
|
|
|
|
57
|
push @{$self->{_headers}}, [$name, $value]; |
|
|
52
|
|
|
|
|
112
|
|
|
752
|
52
|
|
50
|
|
|
123
|
my $key = lc($name // ''); |
|
753
|
52
|
50
|
|
|
|
112
|
$self->{_header_set}{$key} = 1 if length $key; |
|
754
|
52
|
100
|
|
|
|
83
|
if ($key eq 'content-type') { |
|
755
|
1
|
|
|
|
|
3
|
$self->{_content_type} = $value; |
|
756
|
|
|
|
|
|
|
} |
|
757
|
52
|
|
|
|
|
65
|
return $self; |
|
758
|
|
|
|
|
|
|
} |
|
759
|
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
sub headers { |
|
761
|
1
|
|
|
1
|
1
|
284
|
my ($self) = @_; |
|
762
|
1
|
|
|
|
|
4
|
return $self->{_headers}; |
|
763
|
|
|
|
|
|
|
} |
|
764
|
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
sub header_all { |
|
766
|
1
|
|
|
1
|
1
|
3
|
my ($self, $name) = @_; |
|
767
|
1
|
50
|
|
|
|
5
|
croak("Header name is required") unless defined $name; |
|
768
|
1
|
|
|
|
|
2
|
my $key = lc($name); |
|
769
|
1
|
|
|
|
|
2
|
my @values; |
|
770
|
1
|
|
|
|
|
1
|
for my $pair (@{$self->{_headers}}) { |
|
|
1
|
|
|
|
|
3
|
|
|
771
|
1
|
50
|
|
|
|
5
|
push @values, $pair->[1] if lc($pair->[0]) eq $key; |
|
772
|
|
|
|
|
|
|
} |
|
773
|
1
|
|
|
|
|
3
|
return @values; |
|
774
|
|
|
|
|
|
|
} |
|
775
|
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
sub header_try { |
|
777
|
2
|
|
|
2
|
1
|
4
|
my ($self, $name, $value) = @_; |
|
778
|
2
|
100
|
|
|
|
4
|
return $self if $self->has_header($name); |
|
779
|
1
|
|
|
|
|
4
|
return $self->header($name, $value); |
|
780
|
|
|
|
|
|
|
} |
|
781
|
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
sub content_type { |
|
783
|
51
|
|
|
51
|
1
|
1938
|
my ($self, $type) = @_; |
|
784
|
51
|
100
|
|
|
|
111
|
return $self->{_content_type} if @_ == 1; |
|
785
|
|
|
|
|
|
|
# Remove existing content-type headers |
|
786
|
49
|
|
|
|
|
57
|
$self->{_headers} = [grep { lc($_->[0]) ne 'content-type' } @{$self->{_headers}}]; |
|
|
28
|
|
|
|
|
80
|
|
|
|
49
|
|
|
|
|
121
|
|
|
787
|
49
|
|
|
|
|
64
|
push @{$self->{_headers}}, ['content-type', $type]; |
|
|
49
|
|
|
|
|
108
|
|
|
788
|
49
|
|
|
|
|
107
|
$self->{_header_set}{'content-type'} = 1; |
|
789
|
49
|
|
|
|
|
77
|
$self->{_content_type} = $type; |
|
790
|
49
|
|
|
|
|
117
|
return $self; |
|
791
|
|
|
|
|
|
|
} |
|
792
|
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
sub content_type_try { |
|
794
|
2
|
|
|
2
|
1
|
556
|
my ($self, $type) = @_; |
|
795
|
2
|
100
|
|
|
|
5
|
return $self if exists $self->{_content_type}; |
|
796
|
1
|
|
|
|
|
3
|
return $self->content_type($type); |
|
797
|
|
|
|
|
|
|
} |
|
798
|
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
sub has_status { |
|
800
|
2
|
|
|
2
|
1
|
6
|
my ($self) = @_; |
|
801
|
2
|
100
|
|
|
|
11
|
return exists $self->{_status} ? 1 : 0; |
|
802
|
|
|
|
|
|
|
} |
|
803
|
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
sub has_header { |
|
805
|
4
|
|
|
4
|
1
|
6
|
my ($self, $name) = @_; |
|
806
|
4
|
|
50
|
|
|
8
|
my $key = lc($name // ''); |
|
807
|
4
|
50
|
|
|
|
7
|
return 0 unless length $key; |
|
808
|
4
|
100
|
|
|
|
14
|
return $self->{_header_set}{$key} ? 1 : 0; |
|
809
|
|
|
|
|
|
|
} |
|
810
|
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
sub has_content_type { |
|
812
|
2
|
|
|
2
|
1
|
4
|
my ($self) = @_; |
|
813
|
2
|
100
|
|
|
|
25
|
return exists $self->{_content_type} ? 1 : 0; |
|
814
|
|
|
|
|
|
|
} |
|
815
|
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
# Per-request storage - lives in scope, shared across Request/Response/WebSocket/SSE |
|
817
|
|
|
|
|
|
|
# |
|
818
|
|
|
|
|
|
|
# DESIGN NOTE: Stash is intentionally scope-based, not object-based. When middleware |
|
819
|
|
|
|
|
|
|
# creates a shallow copy of scope ({ %$scope, key => val }), the inner 'pagi.stash' |
|
820
|
|
|
|
|
|
|
# hashref is preserved by reference. This means: |
|
821
|
|
|
|
|
|
|
# 1. All Request/Response objects created from the same scope chain share stash |
|
822
|
|
|
|
|
|
|
# 2. Middleware modifications to stash are visible to downstream handlers |
|
823
|
|
|
|
|
|
|
# 3. The stash "transcends" the middleware chain via scope, not via object identity |
|
824
|
|
|
|
|
|
|
# |
|
825
|
|
|
|
|
|
|
# This addresses a potential concern about Request objects being ephemeral - stash |
|
826
|
|
|
|
|
|
|
# works correctly because it lives in scope, which IS shared across the chain. |
|
827
|
|
|
|
|
|
|
sub stash { |
|
828
|
10
|
|
|
10
|
1
|
113
|
my ($self) = @_; |
|
829
|
10
|
50
|
|
|
|
26
|
return {} unless $self->{scope}; |
|
830
|
10
|
|
100
|
|
|
64
|
return $self->{scope}{'pagi.stash'} //= {}; |
|
831
|
|
|
|
|
|
|
} |
|
832
|
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
sub is_sent { |
|
834
|
6
|
|
|
6
|
1
|
93
|
my ($self) = @_; |
|
835
|
6
|
100
|
|
|
|
23
|
return $self->{scope}{'pagi.response.sent'} ? 1 : 0; |
|
836
|
|
|
|
|
|
|
} |
|
837
|
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
sub _mark_sent { |
|
839
|
63
|
|
|
63
|
|
88
|
my ($self) = @_; |
|
840
|
63
|
100
|
|
|
|
369
|
croak("Response already sent") if $self->{scope}{'pagi.response.sent'}; |
|
841
|
61
|
|
|
|
|
123
|
$self->{scope}{'pagi.response.sent'} = 1; |
|
842
|
|
|
|
|
|
|
} |
|
843
|
|
|
|
|
|
|
|
|
844
|
52
|
|
|
52
|
1
|
131
|
async sub send_raw { |
|
845
|
52
|
|
|
|
|
99
|
my ($self, $body) = @_; |
|
846
|
52
|
|
|
|
|
131
|
$self->_mark_sent; |
|
847
|
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
# Send start |
|
849
|
|
|
|
|
|
|
await $self->{send}->({ |
|
850
|
|
|
|
|
|
|
type => 'http.response.start', |
|
851
|
|
|
|
|
|
|
status => $self->status, # uses lazy default of 200 |
|
852
|
|
|
|
|
|
|
headers => $self->{_headers}, |
|
853
|
50
|
|
|
|
|
109
|
}); |
|
854
|
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
# Send body |
|
856
|
50
|
|
|
|
|
2169
|
await $self->{send}->({ |
|
857
|
|
|
|
|
|
|
type => 'http.response.body', |
|
858
|
|
|
|
|
|
|
body => $body, |
|
859
|
|
|
|
|
|
|
more => 0, |
|
860
|
|
|
|
|
|
|
}); |
|
861
|
|
|
|
|
|
|
} |
|
862
|
|
|
|
|
|
|
|
|
863
|
17
|
|
|
17
|
1
|
25
|
async sub send { |
|
864
|
17
|
|
|
|
|
34
|
my ($self, $body, %opts) = @_; |
|
865
|
17
|
|
50
|
|
|
62
|
my $charset = $opts{charset} // 'utf-8'; |
|
866
|
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
# Ensure content-type has charset |
|
868
|
17
|
|
|
|
|
22
|
my $has_ct = 0; |
|
869
|
17
|
|
|
|
|
19
|
for my $h (@{$self->{_headers}}) { |
|
|
17
|
|
|
|
|
31
|
|
|
870
|
22
|
100
|
|
|
|
54
|
if (lc($h->[0]) eq 'content-type') { |
|
871
|
16
|
|
|
|
|
18
|
$has_ct = 1; |
|
872
|
16
|
50
|
|
|
|
92
|
unless ($h->[1] =~ /charset=/i) { |
|
873
|
0
|
|
|
|
|
0
|
$h->[1] .= "; charset=$charset"; |
|
874
|
|
|
|
|
|
|
} |
|
875
|
16
|
|
|
|
|
24
|
last; |
|
876
|
|
|
|
|
|
|
} |
|
877
|
|
|
|
|
|
|
} |
|
878
|
17
|
100
|
|
|
|
36
|
unless ($has_ct) { |
|
879
|
1
|
|
|
|
|
2
|
push @{$self->{_headers}}, ['content-type', "text/plain; charset=$charset"]; |
|
|
1
|
|
|
|
|
3
|
|
|
880
|
|
|
|
|
|
|
} |
|
881
|
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
# Encode body |
|
883
|
17
|
|
50
|
|
|
175
|
my $encoded = encode($charset, $body // '', FB_CROAK); |
|
884
|
|
|
|
|
|
|
|
|
885
|
17
|
|
|
|
|
1243
|
await $self->send_raw($encoded); |
|
886
|
|
|
|
|
|
|
} |
|
887
|
|
|
|
|
|
|
|
|
888
|
13
|
|
|
13
|
1
|
2282
|
async sub text { |
|
889
|
13
|
|
|
|
|
25
|
my ($self, $body) = @_; |
|
890
|
13
|
|
|
|
|
36
|
$self->content_type('text/plain; charset=utf-8'); |
|
891
|
13
|
|
|
|
|
30
|
await $self->send($body); |
|
892
|
|
|
|
|
|
|
} |
|
893
|
|
|
|
|
|
|
|
|
894
|
3
|
|
|
3
|
1
|
11
|
async sub html { |
|
895
|
3
|
|
|
|
|
6
|
my ($self, $body) = @_; |
|
896
|
3
|
|
|
|
|
28
|
$self->content_type('text/html; charset=utf-8'); |
|
897
|
3
|
|
|
|
|
8
|
await $self->send($body); |
|
898
|
|
|
|
|
|
|
} |
|
899
|
|
|
|
|
|
|
|
|
900
|
19
|
|
|
19
|
1
|
1644
|
async sub json { |
|
901
|
19
|
|
|
|
|
37
|
my ($self, $data) = @_; |
|
902
|
19
|
|
|
|
|
52
|
$self->content_type('application/json; charset=utf-8'); |
|
903
|
19
|
|
|
|
|
116
|
my $body = JSON::MaybeXS->new(utf8 => 1, canonical => 1)->encode($data); |
|
904
|
19
|
|
|
|
|
513
|
await $self->send_raw($body); |
|
905
|
|
|
|
|
|
|
} |
|
906
|
|
|
|
|
|
|
|
|
907
|
5
|
|
|
5
|
1
|
21
|
async sub redirect { |
|
908
|
5
|
|
|
|
|
9
|
my ($self, $url, $status) = @_; |
|
909
|
5
|
|
100
|
|
|
18
|
$status //= 302; |
|
910
|
5
|
|
|
|
|
8
|
$self->{_status} = $status; |
|
911
|
5
|
|
|
|
|
15
|
$self->header('location', $url); |
|
912
|
5
|
|
|
|
|
12
|
await $self->send_raw(''); |
|
913
|
|
|
|
|
|
|
} |
|
914
|
|
|
|
|
|
|
|
|
915
|
5
|
|
|
5
|
1
|
17
|
async sub empty { |
|
916
|
5
|
|
|
|
|
10
|
my ($self) = @_; |
|
917
|
|
|
|
|
|
|
# Use 204 if status hasn't been explicitly set |
|
918
|
5
|
100
|
|
|
|
14
|
unless (exists $self->{_status}) { |
|
919
|
2
|
|
|
|
|
4
|
$self->{_status} = 204; |
|
920
|
|
|
|
|
|
|
} |
|
921
|
5
|
|
|
|
|
14
|
await $self->send_raw(undef); |
|
922
|
|
|
|
|
|
|
} |
|
923
|
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
sub cookie { |
|
925
|
6
|
|
|
6
|
1
|
37
|
my ($self, $name, $value, %opts) = @_; |
|
926
|
6
|
|
|
|
|
12
|
my @parts = ("$name=$value"); |
|
927
|
|
|
|
|
|
|
|
|
928
|
6
|
100
|
|
|
|
18
|
push @parts, "Max-Age=$opts{max_age}" if defined $opts{max_age}; |
|
929
|
6
|
50
|
|
|
|
11
|
push @parts, "Expires=$opts{expires}" if defined $opts{expires}; |
|
930
|
6
|
100
|
|
|
|
15
|
push @parts, "Path=$opts{path}" if defined $opts{path}; |
|
931
|
6
|
100
|
|
|
|
12
|
push @parts, "Domain=$opts{domain}" if defined $opts{domain}; |
|
932
|
6
|
100
|
|
|
|
10
|
push @parts, "Secure" if $opts{secure}; |
|
933
|
6
|
100
|
|
|
|
11
|
push @parts, "HttpOnly" if $opts{httponly}; |
|
934
|
6
|
100
|
|
|
|
12
|
push @parts, "SameSite=$opts{samesite}" if defined $opts{samesite}; |
|
935
|
|
|
|
|
|
|
|
|
936
|
6
|
|
|
|
|
14
|
my $cookie_str = join('; ', @parts); |
|
937
|
6
|
|
|
|
|
8
|
push @{$self->{_headers}}, ['set-cookie', $cookie_str]; |
|
|
6
|
|
|
|
|
12
|
|
|
938
|
|
|
|
|
|
|
|
|
939
|
6
|
|
|
|
|
18
|
return $self; |
|
940
|
|
|
|
|
|
|
} |
|
941
|
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
sub delete_cookie { |
|
943
|
1
|
|
|
1
|
1
|
7
|
my ($self, $name, %opts) = @_; |
|
944
|
|
|
|
|
|
|
return $self->cookie($name, '', |
|
945
|
|
|
|
|
|
|
max_age => 0, |
|
946
|
|
|
|
|
|
|
path => $opts{path}, |
|
947
|
|
|
|
|
|
|
domain => $opts{domain}, |
|
948
|
1
|
|
|
|
|
6
|
); |
|
949
|
|
|
|
|
|
|
} |
|
950
|
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
sub cors { |
|
952
|
8
|
|
|
8
|
1
|
59
|
my ($self, %opts) = @_; |
|
953
|
8
|
|
100
|
|
|
25
|
my $origin = $opts{origin} // '*'; |
|
954
|
8
|
|
100
|
|
|
25
|
my $credentials = $opts{credentials} // 0; |
|
955
|
8
|
|
100
|
|
|
53
|
my $methods = $opts{methods} // [qw(GET POST PUT DELETE PATCH OPTIONS)]; |
|
956
|
8
|
|
100
|
|
|
33
|
my $headers = $opts{headers} // [qw(Content-Type Authorization X-Requested-With)]; |
|
957
|
8
|
|
100
|
|
|
23
|
my $expose = $opts{expose} // []; |
|
958
|
8
|
|
100
|
|
|
20
|
my $max_age = $opts{max_age} // 86400; |
|
959
|
8
|
|
100
|
|
|
20
|
my $preflight = $opts{preflight} // 0; |
|
960
|
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
# Determine the origin to send back |
|
962
|
8
|
|
|
|
|
8
|
my $allow_origin; |
|
963
|
8
|
100
|
100
|
|
|
23
|
if ($origin eq '*' && $credentials) { |
|
964
|
|
|
|
|
|
|
# With credentials, can't use wildcard - use request_origin if provided |
|
965
|
1
|
|
50
|
|
|
2
|
$allow_origin = $opts{request_origin} // '*'; |
|
966
|
|
|
|
|
|
|
} else { |
|
967
|
7
|
|
|
|
|
11
|
$allow_origin = $origin; |
|
968
|
|
|
|
|
|
|
} |
|
969
|
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
# Core CORS headers (always set) |
|
971
|
8
|
|
|
|
|
23
|
$self->header('Access-Control-Allow-Origin', $allow_origin); |
|
972
|
8
|
|
|
|
|
13
|
$self->header('Vary', 'Origin'); |
|
973
|
|
|
|
|
|
|
|
|
974
|
8
|
100
|
|
|
|
14
|
if ($credentials) { |
|
975
|
3
|
|
|
|
|
7
|
$self->header('Access-Control-Allow-Credentials', 'true'); |
|
976
|
|
|
|
|
|
|
} |
|
977
|
|
|
|
|
|
|
|
|
978
|
8
|
100
|
|
|
|
16
|
if (@$expose) { |
|
979
|
2
|
|
|
|
|
9
|
$self->header('Access-Control-Expose-Headers', join(', ', @$expose)); |
|
980
|
|
|
|
|
|
|
} |
|
981
|
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
# Preflight headers (for OPTIONS responses or when explicitly requested) |
|
983
|
8
|
100
|
|
|
|
18
|
if ($preflight) { |
|
984
|
2
|
|
|
|
|
11
|
$self->header('Access-Control-Allow-Methods', join(', ', @$methods)); |
|
985
|
2
|
|
|
|
|
8
|
$self->header('Access-Control-Allow-Headers', join(', ', @$headers)); |
|
986
|
2
|
|
|
|
|
6
|
$self->header('Access-Control-Max-Age', $max_age); |
|
987
|
|
|
|
|
|
|
} |
|
988
|
|
|
|
|
|
|
|
|
989
|
8
|
|
|
|
|
39
|
return $self; |
|
990
|
|
|
|
|
|
|
} |
|
991
|
|
|
|
|
|
|
|
|
992
|
3
|
|
|
3
|
1
|
17
|
async sub stream { |
|
993
|
3
|
|
|
|
|
7
|
my ($self, $callback) = @_; |
|
994
|
3
|
|
|
|
|
10
|
$self->_mark_sent; |
|
995
|
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
# Send start |
|
997
|
|
|
|
|
|
|
await $self->{send}->({ |
|
998
|
|
|
|
|
|
|
type => 'http.response.start', |
|
999
|
|
|
|
|
|
|
status => $self->status, # uses lazy default of 200 |
|
1000
|
|
|
|
|
|
|
headers => $self->{_headers}, |
|
1001
|
3
|
|
|
|
|
9
|
}); |
|
1002
|
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
# Create writer and call callback |
|
1004
|
3
|
|
|
|
|
135
|
my $writer = PAGI::Response::Writer->new($self->{send}); |
|
1005
|
3
|
|
|
|
|
8
|
await $callback->($writer); |
|
1006
|
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
# Ensure closed |
|
1008
|
3
|
100
|
|
|
|
194
|
await $writer->close() unless $writer->{closed}; |
|
1009
|
|
|
|
|
|
|
} |
|
1010
|
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
# Simple MIME type mapping |
|
1012
|
|
|
|
|
|
|
my %MIME_TYPES = ( |
|
1013
|
|
|
|
|
|
|
'.html' => 'text/html', |
|
1014
|
|
|
|
|
|
|
'.htm' => 'text/html', |
|
1015
|
|
|
|
|
|
|
'.txt' => 'text/plain', |
|
1016
|
|
|
|
|
|
|
'.css' => 'text/css', |
|
1017
|
|
|
|
|
|
|
'.js' => 'application/javascript', |
|
1018
|
|
|
|
|
|
|
'.json' => 'application/json', |
|
1019
|
|
|
|
|
|
|
'.xml' => 'application/xml', |
|
1020
|
|
|
|
|
|
|
'.pdf' => 'application/pdf', |
|
1021
|
|
|
|
|
|
|
'.zip' => 'application/zip', |
|
1022
|
|
|
|
|
|
|
'.png' => 'image/png', |
|
1023
|
|
|
|
|
|
|
'.jpg' => 'image/jpeg', |
|
1024
|
|
|
|
|
|
|
'.jpeg' => 'image/jpeg', |
|
1025
|
|
|
|
|
|
|
'.gif' => 'image/gif', |
|
1026
|
|
|
|
|
|
|
'.svg' => 'image/svg+xml', |
|
1027
|
|
|
|
|
|
|
'.ico' => 'image/x-icon', |
|
1028
|
|
|
|
|
|
|
'.woff' => 'font/woff', |
|
1029
|
|
|
|
|
|
|
'.woff2'=> 'font/woff2', |
|
1030
|
|
|
|
|
|
|
); |
|
1031
|
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
sub _mime_type { |
|
1033
|
8
|
|
|
8
|
|
11
|
my ($path) = @_; |
|
1034
|
8
|
|
|
|
|
33
|
my ($ext) = $path =~ /(\.[^.]+)$/; |
|
1035
|
8
|
|
100
|
|
|
54
|
return $MIME_TYPES{lc($ext // '')} // 'application/octet-stream'; |
|
|
|
|
100
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
} |
|
1037
|
|
|
|
|
|
|
|
|
1038
|
12
|
|
|
12
|
1
|
108
|
async sub send_file { |
|
1039
|
12
|
|
|
|
|
33
|
my ($self, $path, %opts) = @_; |
|
1040
|
12
|
100
|
|
|
|
345
|
croak("File not found: $path") unless -f $path; |
|
1041
|
11
|
50
|
|
|
|
107
|
croak("Cannot read file: $path") unless -r $path; |
|
1042
|
|
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
|
# Get file size |
|
1044
|
11
|
|
|
|
|
53
|
my $file_size = -s $path; |
|
1045
|
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
# Handle offset and length for range requests |
|
1047
|
11
|
|
100
|
|
|
42
|
my $offset = $opts{offset} // 0; |
|
1048
|
11
|
|
|
|
|
16
|
my $length = $opts{length}; |
|
1049
|
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
# Validate offset |
|
1051
|
11
|
100
|
|
|
|
135
|
croak("offset must be non-negative") if $offset < 0; |
|
1052
|
10
|
100
|
|
|
|
124
|
croak("offset exceeds file size") if $offset > $file_size; |
|
1053
|
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
# Calculate actual length to send |
|
1055
|
9
|
|
|
|
|
11
|
my $max_length = $file_size - $offset; |
|
1056
|
9
|
100
|
|
|
|
20
|
if (defined $length) { |
|
1057
|
3
|
100
|
|
|
|
127
|
croak("length must be non-negative") if $length < 0; |
|
1058
|
2
|
100
|
|
|
|
6
|
$length = $max_length if $length > $max_length; |
|
1059
|
|
|
|
|
|
|
} else { |
|
1060
|
6
|
|
|
|
|
9
|
$length = $max_length; |
|
1061
|
|
|
|
|
|
|
} |
|
1062
|
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
# Set content-type if not already set |
|
1064
|
8
|
|
|
|
|
11
|
my $has_ct = grep { lc($_->[0]) eq 'content-type' } @{$self->{_headers}}; |
|
|
0
|
|
|
|
|
0
|
|
|
|
8
|
|
|
|
|
19
|
|
|
1065
|
8
|
50
|
|
|
|
19
|
unless ($has_ct) { |
|
1066
|
8
|
|
|
|
|
19
|
$self->content_type(_mime_type($path)); |
|
1067
|
|
|
|
|
|
|
} |
|
1068
|
|
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
|
# Set content-length based on actual bytes to send |
|
1070
|
8
|
|
|
|
|
23
|
$self->header('content-length', $length); |
|
1071
|
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
# Set content-disposition |
|
1073
|
8
|
|
|
|
|
9
|
my $disposition; |
|
1074
|
8
|
100
|
|
|
|
35
|
if ($opts{inline}) { |
|
|
|
100
|
|
|
|
|
|
|
1075
|
1
|
|
|
|
|
2
|
$disposition = 'inline'; |
|
1076
|
|
|
|
|
|
|
} elsif ($opts{filename}) { |
|
1077
|
|
|
|
|
|
|
# Sanitize filename for header |
|
1078
|
2
|
|
|
|
|
6
|
my $safe_filename = $opts{filename}; |
|
1079
|
2
|
|
|
|
|
7
|
$safe_filename =~ s/["\r\n]//g; |
|
1080
|
2
|
|
|
|
|
4
|
$disposition = "attachment; filename=\"$safe_filename\""; |
|
1081
|
|
|
|
|
|
|
} |
|
1082
|
8
|
100
|
|
|
|
19
|
$self->header('content-disposition', $disposition) if $disposition; |
|
1083
|
|
|
|
|
|
|
|
|
1084
|
8
|
|
|
|
|
22
|
$self->_mark_sent; |
|
1085
|
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
# Send response start |
|
1087
|
|
|
|
|
|
|
await $self->{send}->({ |
|
1088
|
|
|
|
|
|
|
type => 'http.response.start', |
|
1089
|
|
|
|
|
|
|
status => $self->status, # uses lazy default of 200 |
|
1090
|
|
|
|
|
|
|
headers => $self->{_headers}, |
|
1091
|
8
|
|
|
|
|
44
|
}); |
|
1092
|
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
# Use PAGI file protocol for efficient server-side streaming |
|
1094
|
8
|
|
|
|
|
313
|
my $body_event = { |
|
1095
|
|
|
|
|
|
|
type => 'http.response.body', |
|
1096
|
|
|
|
|
|
|
file => $path, |
|
1097
|
|
|
|
|
|
|
}; |
|
1098
|
|
|
|
|
|
|
|
|
1099
|
|
|
|
|
|
|
# Add offset/length only if not reading from start or not full file |
|
1100
|
8
|
100
|
|
|
|
17
|
$body_event->{offset} = $offset if $offset > 0; |
|
1101
|
8
|
100
|
|
|
|
18
|
$body_event->{length} = $length if $length < $max_length; |
|
1102
|
|
|
|
|
|
|
|
|
1103
|
8
|
|
|
|
|
49
|
await $self->{send}->($body_event); |
|
1104
|
|
|
|
|
|
|
} |
|
1105
|
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
# Writer class for streaming responses |
|
1107
|
|
|
|
|
|
|
package PAGI::Response::Writer { |
|
1108
|
7
|
|
|
7
|
|
85
|
use strict; |
|
|
7
|
|
|
|
|
11
|
|
|
|
7
|
|
|
|
|
185
|
|
|
1109
|
7
|
|
|
7
|
|
28
|
use warnings; |
|
|
7
|
|
|
|
|
19
|
|
|
|
7
|
|
|
|
|
427
|
|
|
1110
|
7
|
|
|
7
|
|
28
|
use Future::AsyncAwait; |
|
|
7
|
|
|
|
|
9
|
|
|
|
7
|
|
|
|
|
39
|
|
|
1111
|
7
|
|
|
7
|
|
326
|
use Carp qw(croak); |
|
|
7
|
|
|
|
|
8
|
|
|
|
7
|
|
|
|
|
2729
|
|
|
1112
|
|
|
|
|
|
|
|
|
1113
|
|
|
|
|
|
|
sub new { |
|
1114
|
3
|
|
|
3
|
|
7
|
my ($class, $send) = @_; |
|
1115
|
3
|
|
|
|
|
11
|
return bless { |
|
1116
|
|
|
|
|
|
|
send => $send, |
|
1117
|
|
|
|
|
|
|
bytes_written => 0, |
|
1118
|
|
|
|
|
|
|
closed => 0, |
|
1119
|
|
|
|
|
|
|
}, $class; |
|
1120
|
|
|
|
|
|
|
} |
|
1121
|
|
|
|
|
|
|
|
|
1122
|
7
|
|
|
7
|
|
206
|
async sub write { |
|
1123
|
7
|
|
|
|
|
11
|
my ($self, $chunk) = @_; |
|
1124
|
7
|
50
|
|
|
|
22
|
croak("Writer already closed") if $self->{closed}; |
|
1125
|
7
|
|
50
|
|
|
15
|
$self->{bytes_written} += length($chunk // ''); |
|
1126
|
7
|
|
|
|
|
23
|
await $self->{send}->({ |
|
1127
|
|
|
|
|
|
|
type => 'http.response.body', |
|
1128
|
|
|
|
|
|
|
body => $chunk, |
|
1129
|
|
|
|
|
|
|
more => 1, |
|
1130
|
|
|
|
|
|
|
}); |
|
1131
|
|
|
|
|
|
|
} |
|
1132
|
|
|
|
|
|
|
|
|
1133
|
3
|
|
|
3
|
|
46
|
async sub close { |
|
1134
|
3
|
|
|
|
|
4
|
my ($self) = @_; |
|
1135
|
3
|
50
|
|
|
|
7
|
return if $self->{closed}; |
|
1136
|
3
|
|
|
|
|
6
|
$self->{closed} = 1; |
|
1137
|
3
|
|
|
|
|
11
|
await $self->{send}->({ |
|
1138
|
|
|
|
|
|
|
type => 'http.response.body', |
|
1139
|
|
|
|
|
|
|
body => '', |
|
1140
|
|
|
|
|
|
|
more => 0, |
|
1141
|
|
|
|
|
|
|
}); |
|
1142
|
|
|
|
|
|
|
} |
|
1143
|
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
sub bytes_written { |
|
1145
|
1
|
|
|
1
|
|
43
|
my ($self) = @_; |
|
1146
|
1
|
|
|
|
|
2
|
return $self->{bytes_written}; |
|
1147
|
|
|
|
|
|
|
} |
|
1148
|
|
|
|
|
|
|
} |
|
1149
|
|
|
|
|
|
|
|
|
1150
|
|
|
|
|
|
|
1; |