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.002000';
3 1     1   1045 use strict;
  1         2  
  1         54  
4 1     1   6 use warnings;
  1         2  
  1         86  
5 1     1   8 use parent 'PAGI::Middleware';
  1         2  
  1         9  
6 1     1   111 use Future::AsyncAwait;
  1         2  
  1         11  
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   18 my ($self, $config) = @_;
63              
64             $self->{supported_types} = $config->{supported_types}
65 6   50     36 // die "ContentNegotiation requires 'supported_types' option";
66             $self->{default_type} = $config->{default_type}
67 6   66     42 // $self->{supported_types}[0];
68 6   100     40 $self->{strict} = $config->{strict} // 0;
69             }
70              
71             sub wrap {
72 6     6 1 78 my ($self, $app) = @_;
73              
74 6     6   211 return async sub {
75 6         15 my ($scope, $receive, $send) = @_;
76 6 50       25 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     25 my $accept = $self->_get_header($scope, 'accept') // '*/*';
83 6         85 my $preferred = $self->_negotiate($accept);
84              
85 6 100 100     31 if (!$preferred && $self->{strict}) {
86 1         5 await $self->_send_not_acceptable($send);
87 1         87 return;
88             }
89              
90 5   66     43 $preferred //= $self->{default_type};
91              
92             # Add preferred type to scope
93 5         18 my @accepted = $self->_parse_accept($accept);
94 5         69 my $new_scope = $self->modify_scope($scope, {
95             'pagi.preferred_content_type' => $preferred,
96             'pagi.accepted_types' => \@accepted,
97             });
98              
99 5         30 await $app->($new_scope, $receive, $send);
100 6         39 };
101             }
102              
103             sub _negotiate {
104 6     6   20 my ($self, $accept) = @_;
105              
106 6         28 my @accepted = $self->_parse_accept($accept);
107 6 50       26 return unless @accepted;
108              
109 6         14 for my $item (@accepted) {
110 6         21 my $type = $item->{type};
111              
112             # Check for exact match
113 6         13 for my $supported (@{$self->{supported_types}}) {
  6         18  
114 12 100       46 return $supported if lc($type) eq lc($supported);
115             }
116              
117             # Check for wildcard matches
118 5 100       19 if ($type eq '*/*') {
119 2         14 return $self->{supported_types}[0];
120             }
121              
122 3 100       23 if ($type =~ m{^([^/]+)/\*$}) {
123 1         5 my $major = lc($1);
124 1         2 for my $supported (@{$self->{supported_types}}) {
  1         3  
125 2 100       44 return $supported if $supported =~ m{^$major/}i;
126             }
127             }
128             }
129              
130 2         10 return;
131             }
132              
133             sub _parse_accept {
134 11     11   25 my ($self, $accept) = @_;
135              
136 11         23 my @items;
137              
138 11         83 for my $part (split /\s*,\s*/, $accept) {
139 13         54 my ($type, @params) = split /\s*;\s*/, $part;
140 13 50       38 next unless $type;
141              
142 13         23 my $q = 1.0;
143 13         30 for my $param (@params) {
144 2 50       14 if ($param =~ /^q\s*=\s*([0-9.]+)$/i) {
145 2         18 $q = $1 + 0;
146 2         5 last;
147             }
148             }
149              
150 13         66 push @items, { type => $type, q => $q };
151             }
152              
153             # Sort by quality value, descending
154 11         67 @items = sort { $b->{q} <=> $a->{q} } @items;
  2         12  
155              
156 11         51 return @items;
157             }
158              
159             sub _get_header {
160 6     6   17 my ($self, $scope, $name) = @_;
161              
162 6         14 $name = lc($name);
163 6   50     13 for my $h (@{$scope->{headers} // []}) {
  6         25  
164 5 50       38 return $h->[1] if lc($h->[0]) eq $name;
165             }
166 1         39 return;
167             }
168              
169 1     1   3 async sub _send_not_acceptable {
170 1         3 my ($self, $send) = @_;
171              
172 1         2 my $supported = join(', ', @{$self->{supported_types}});
  1         6  
173 1         4 my $body = "Not Acceptable. Supported types: $supported";
174              
175 1         11 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         117 await $send->({
184             type => 'http.response.body',
185             body => $body,
186             more => 0,
187             });
188             }
189              
190             1;
191              
192             __END__