File Coverage

blib/lib/PAGI/Response.pm
Criterion Covered Total %
statement 239 242 98.7
branch 95 108 87.9
condition 43 50 86.0
subroutine 42 42 100.0
pod 26 26 100.0
total 445 468 95.0


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
, 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
or
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;