File Coverage

blib/lib/PAGI/Middleware/ContentNegotiation.pm
Criterion Covered Total %
statement 73 75 97.3
branch 15 20 75.0
condition 13 17 76.4
subroutine 11 11 100.0
pod 1 1 100.0
total 113 124 91.1


line stmt bran cond sub pod time code
1             package PAGI::Middleware::ContentNegotiation;
2             $PAGI::Middleware::ContentNegotiation::VERSION = '0.002001';
3 1     1   466 use strict;
  1         2  
  1         31  
4 1     1   3 use warnings;
  1         6  
  1         37  
5 1     1   3 use parent 'PAGI::Middleware';
  1         2  
  1         4  
6 1     1   62 use Future::AsyncAwait;
  1         1  
  1         5  
7              
8             =head1 NAME
9              
10             PAGI::Middleware::ContentNegotiation - HTTP content negotiation middleware
11              
12             =head1 SYNOPSIS
13              
14             use PAGI::Middleware::Builder;
15              
16             my $app = builder {
17             enable 'ContentNegotiation',
18             supported_types => ['application/json', 'text/html', 'text/plain'],
19             default_type => 'application/json';
20             $my_app;
21             };
22              
23             # In your app:
24             async sub app {
25             my ($scope, $receive, $send) = @_;
26              
27             my $preferred = $scope->{'pagi.preferred_content_type'};
28             if ($preferred eq 'application/json') {
29             # Return JSON
30             } else {
31             # Return HTML
32             }
33             }
34              
35             =head1 DESCRIPTION
36              
37             PAGI::Middleware::ContentNegotiation parses the Accept header and determines
38             the best content type to return. It adds the preferred type to the scope
39             for the application to use.
40              
41             =head1 CONFIGURATION
42              
43             =over 4
44              
45             =item * supported_types (required)
46              
47             Array of MIME types the application supports.
48              
49             =item * default_type (optional)
50              
51             Default type when no Accept header or no match. Defaults to first supported type.
52              
53             =item * strict (default: 0)
54              
55             If true, return 406 Not Acceptable when no supported type matches.
56              
57             =back
58              
59             =cut
60              
61             sub _init {
62 6     6   11 my ($self, $config) = @_;
63              
64             $self->{supported_types} = $config->{supported_types}
65 6   50     19 // die "ContentNegotiation requires 'supported_types' option";
66             $self->{default_type} = $config->{default_type}
67 6   66     22 // $self->{supported_types}[0];
68 6   100     19 $self->{strict} = $config->{strict} // 0;
69             }
70              
71             sub wrap {
72 6     6 1 53 my ($self, $app) = @_;
73              
74 6     6   126 return async sub {
75 6         9 my ($scope, $receive, $send) = @_;
76 6 50       13 if ($scope->{type} ne 'http') {
77 0         0 await $app->($scope, $receive, $send);
78 0         0 return;
79             }
80              
81             # Parse Accept header
82 6   100     13 my $accept = $self->_get_header($scope, 'accept') // '*/*';
83 6         12 my $preferred = $self->_negotiate($accept);
84              
85 6 100 100     17 if (!$preferred && $self->{strict}) {
86 1         8 await $self->_send_not_acceptable($send);
87 1         46 return;
88             }
89              
90 5   66     13 $preferred //= $self->{default_type};
91              
92             # Add preferred type to scope
93 5         10 my @accepted = $self->_parse_accept($accept);
94 5         22 my $new_scope = $self->modify_scope($scope, {
95             'pagi.preferred_content_type' => $preferred,
96             'pagi.accepted_types' => \@accepted,
97             });
98              
99 5         14 await $app->($new_scope, $receive, $send);
100 6         21 };
101             }
102              
103             sub _negotiate {
104 6     6   10 my ($self, $accept) = @_;
105              
106 6         12 my @accepted = $self->_parse_accept($accept);
107 6 50       12 return unless @accepted;
108              
109 6         9 for my $item (@accepted) {
110 6         6 my $type = $item->{type};
111              
112             # Check for exact match
113 6         7 for my $supported (@{$self->{supported_types}}) {
  6         9  
114 12 100       25 return $supported if lc($type) eq lc($supported);
115             }
116              
117             # Check for wildcard matches
118 5 100       9 if ($type eq '*/*') {
119 2         6 return $self->{supported_types}[0];
120             }
121              
122 3 100       11 if ($type =~ m{^([^/]+)/\*$}) {
123 1         4 my $major = lc($1);
124 1         2 for my $supported (@{$self->{supported_types}}) {
  1         2  
125 2 100       23 return $supported if $supported =~ m{^$major/}i;
126             }
127             }
128             }
129              
130 2         5 return;
131             }
132              
133             sub _parse_accept {
134 11     11   17 my ($self, $accept) = @_;
135              
136 11         11 my @items;
137              
138 11         29 for my $part (split /\s*,\s*/, $accept) {
139 13         26 my ($type, @params) = split /\s*;\s*/, $part;
140 13 50       20 next unless $type;
141              
142 13         14 my $q = 1.0;
143 13         18 for my $param (@params) {
144 2 50       8 if ($param =~ /^q\s*=\s*([0-9.]+)$/i) {
145 2         8 $q = $1 + 0;
146 2         2 last;
147             }
148             }
149              
150 13         29 push @items, { type => $type, q => $q };
151             }
152              
153             # Sort by quality value, descending
154 11         34 @items = sort { $b->{q} <=> $a->{q} } @items;
  2         7  
155              
156 11         20 return @items;
157             }
158              
159             sub _get_header {
160 6     6   12 my ($self, $scope, $name) = @_;
161              
162 6         8 $name = lc($name);
163 6   50     7 for my $h (@{$scope->{headers} // []}) {
  6         14  
164 5 50       19 return $h->[1] if lc($h->[0]) eq $name;
165             }
166 1         4 return;
167             }
168              
169 1     1   3 async sub _send_not_acceptable {
170 1         2 my ($self, $send) = @_;
171              
172 1         1 my $supported = join(', ', @{$self->{supported_types}});
  1         4  
173 1         2 my $body = "Not Acceptable. Supported types: $supported";
174              
175 1         7 await $send->({
176             type => 'http.response.start',
177             status => 406,
178             headers => [
179             ['Content-Type', 'text/plain'],
180             ['Content-Length', length($body)],
181             ],
182             });
183 1         41 await $send->({
184             type => 'http.response.body',
185             body => $body,
186             more => 0,
187             });
188             }
189              
190             1;
191              
192             __END__