File Coverage

blib/lib/Raisin/Middleware/Formatter.pm
Criterion Covered Total %
statement 103 103 100.0
branch 30 32 93.7
condition 4 4 100.0
subroutine 17 17 100.0
pod 4 5 80.0
total 158 161 98.1


line stmt bran cond sub pod time code
1             #!perl
2             #PODNAME: Raisin::Middleware::Formatter
3             #ABSTRACT: A parser/formatter middleware for L.
4              
5 13     13   548 use strict;
  13         28  
  13         473  
6 13     13   74 use warnings;
  13         27  
  13         695  
7              
8             package Raisin::Middleware::Formatter;
9             $Raisin::Middleware::Formatter::VERSION = '0.92';
10 13     13   86 use parent 'Plack::Middleware';
  13         27  
  13         104  
11              
12 13     13   22438 use File::Basename qw(fileparse);
  13         71  
  13         1328  
13 13     13   101 use HTTP::Status qw(:constants);
  13         24  
  13         5505  
14 13     13   100 use Plack::Request;
  13         34  
  13         369  
15 13     13   551 use Plack::Response;
  13         1249  
  13         340  
16 13     13   72 use Plack::Util;
  13         26  
  13         452  
17 13         65 use Plack::Util::Accessor qw(
18             default_format
19             format
20             encoder
21             decoder
22             raisin
23 13     13   83 );
  13         28  
24              
25             sub call {
26 45     45 1 374887 my ($self, $env) = @_;
27              
28             # Pre-process
29 45         312 my $req = Plack::Request->new($env);
30              
31 45 100       571 if ($req->content) {
32 15         5658 my %media_types_map_flat_hash = $self->decoder->media_types_map_flat_hash;
33              
34 15         76 my ($ctype) = split /;/, $req->content_type, 2;
35 15         135 my $format = $media_types_map_flat_hash{ $ctype};
36 15 100       52 unless ($format) {
37 4         11 Raisin::log(info => "unsupported media type: ${ \$req->content_type }");
  4         13  
38 4         1759 return Plack::Response->new(HTTP_UNSUPPORTED_MEDIA_TYPE)->finalize;
39             }
40 11         28 $env->{'raisinx.decoder'} = $format;
41              
42 11         63 my $d = Plack::Util::load_class($self->decoder->for($format));
43 11         169 $env->{'raisinx.body_params'} = $d->deserialize($req->content);
44             }
45              
46 41         41956 my $format = $self->negotiate_format($req);
47 41 100       134 unless ($format) {
48 3         20 return Plack::Response->new(HTTP_NOT_ACCEPTABLE)->finalize;
49             }
50 38         96 $env->{'raisinx.encoder'} = $format;
51              
52 38         157 my $res = $self->app->($env);
53             # Post-process
54             Plack::Util::response_cb($res, sub {
55             # TODO: delayed responses
56              
57 38     38   539 my $res = shift;
58 38         153 my $r = Plack::Response->new(@$res);
59              
60 38 50       3224 if (ref $r->body) {
61 38         254 my $s = Plack::Util::load_class($self->encoder->for($format));
62              
63 38 50       612 $r->content_type($s->content_type) unless $r->content_type;
64 38         634 $r->body($s->serialize($r->body));
65             }
66              
67 38         90607 @$res = @{ $r->finalize };
  38         119  
68 38         4257 return;
69 38         4143 });
70             }
71              
72 41   100 41   7968 sub _accept_header_set { length(shift || '') }
73             sub _path_has_extension {
74 58     58   4804 my $path = shift;
75 58         1915 my (undef, undef, $suffix) = fileparse($path, qr/\..[^.]*$/);
76 58         254 $suffix;
77             }
78              
79             sub negotiate_format {
80 54     54 1 411 my ($self, $req) = @_;
81              
82 54         167 my @allowed_formats = $self->allowed_formats_for_requested_route($req);
83              
84             # PRECEDENCE:
85             # - extension
86             # - headers
87             # - default
88              
89 54         154 my @wanted_formats = do {
90 54         160 my $ext = _path_has_extension($req->path);
91 54 100       247 if ($ext) {
    100          
92 13         48 $self->format_from_extension($ext);
93             }
94             elsif (_accept_header_set($req->header('Accept'))) {
95             # In case of wildcard matches, we default to first allowed format
96 18         54 $self->format_from_header($req->header('Accept'), $allowed_formats[0]);
97             }
98             else {
99 23         71 $self->default_format;
100             }
101             };
102              
103             my @matching_formats = grep {
104 54         201 my $format = $_;
  52         92  
105 52         90 grep { $format eq $_ } @allowed_formats
  169         375  
106             } @wanted_formats;
107              
108 54         173 shift @matching_formats;
109             }
110              
111             sub format_from_extension {
112 19     19 1 123 my ($self, $ext) = @_;
113 19 100       57 return unless $ext;
114              
115             # Trim leading dot in the extension.
116 18         44 $ext = substr($ext, 1);
117              
118 18         50 my %media_types_map_flat_hash = $self->encoder->media_types_map_flat_hash;
119 18         87 my $format = $media_types_map_flat_hash{ $ext };
120 18 100       64 return unless $format;
121              
122 15         71 $format;
123             }
124              
125             sub format_from_header {
126 28     28 1 660 my ($self, $accept, $assumed_wildcard_format) = @_;
127 28 100       72 return unless $accept;
128              
129 27         71 my %media_types_map_flat_hash = $self->encoder->media_types_map_flat_hash;
130             # Add a default format as a `*/*`
131 27         80 $media_types_map_flat_hash{'*/*'} = $assumed_wildcard_format;
132              
133 27         44 my @media_types;
134 27         134 for my $type (split /\s*,\s*/, $accept) {
135 43         122 my ($media, $params) = split /;/, $type, 2;
136             # Cleaning up media type by deleting a Vendor tree
137 43         90 $media =~ s/vnd\.[^+]+\+//g;
138              
139 43 100       117 next unless my $format = $media_types_map_flat_hash{$media};
140              
141 32 100 100     158 my $q = ($params // '') =~ /q=([\d\.]+)/ ? $1 : 1;
142              
143 32         120 push @media_types, { format => $format, q => $q };
144             }
145              
146 27         91 map { $_->{format} } sort { $b->{q} <=> $a->{q} } @media_types;
  32         159  
  11         34  
147             }
148              
149             sub allowed_formats_for_requested_route {
150 54     54 0 127 my ($self, $req) = @_;
151             # Global format has been forced upon entire app
152 54 100       171 return $self->format if $self->format;
153              
154             # Route specific `produces` restrictions
155 48 100       542 if ( $self->raisin ) {
156 31         196 my $route = $self->raisin->routes->find($req->method, $req->path);
157 31 100       111 return @{$route->{produces}} if $route->{produces};
  4         14  
158             }
159              
160             # Prefer Default, allow all others
161 44         113 my @allowed = keys %{ $self->encoder->all };
  44         128  
162 44 100       169 unshift @allowed, $self->default_format if $self->default_format;
163 44         483 return @allowed;
164             }
165              
166             1;
167              
168             __END__