lib/Catalyst/TraitFor/Request/REST.pm

   1 package Catalyst::TraitFor::Request::REST;
   2
   3 use Moose::Role;
   4 use HTTP::Headers::Util qw(split_header_words);
   5 use namespace::autoclean;
   6
   7 has [qw/ data accept_only /] => ( is => 'rw' );
   8
   9 has accepted_content_types => (
  10     is       => 'ro',
  11     isa      => 'ArrayRef',
  12     lazy     => 1,
  13     builder  => '_build_accepted_content_types',
  14     clearer  => 'clear_accepted_cache',
  15     init_arg => undef,
  16 );
  17
  18 has preferred_content_type => (
  19     is       => 'ro',
  20     isa      => 'Str',
  21     lazy     => 1,
  22     builder  => '_build_preferred_content_type',
  23     init_arg => undef,
  24 );
  25
  26 #
  27 # By default the module looks at both Content-Type and
  28 # Accept and uses the selected content type for both
  29 # deserializing received data and serializing the response.
  30 # However according to RFC 7231, Content-Type should be
  31 # used to specify the payload type of the data sent by
  32 # the requester and Accept should be used to negotiate
  33 # the content type the requester would like back from
  34 # the server. Compliance mode adds support so the method
  35 # described in the RFC is more closely model.
  36 #
  37 # Using a bitmask to represent the the two content type
  38 # header schemes.
  39 # 0x1 for Accept
  40 # 0x2 for Content-Type
  41
  42 has 'compliance_mode' => (
  43     is       => 'ro',
  44     isa      => 'Int',
  45     lazy     => 1,
  46     writer   => '_set_compliance_mode',
  47     default  => 0x3,
  48 );
  49
  50 # Set request object to only use the Accept header when building
  51 # accepted_content_types
  52 sub set_accept_only {
  53     my $self = shift;
  54
  55     # Clear the accepted_content_types cache if we've changed
  56     # allowed headers
  57     $self->clear_accepted_cache();
  58     $self->_set_compliance_mode(0x1);
  59 }
  60
  61 # Set request object to only use the Content-Type header when building
  62 # accepted_content_types
  63 sub set_content_type_only {
  64     my $self = shift;
  65
  66     $self->clear_accepted_cache();
  67     $self->_set_compliance_mode(0x2);
  68 }
  69
  70 # Clear serialize/deserialize compliance mode, allow all headers
  71 # in both situations
  72 sub clear_compliance_mode {
  73     my $self = shift;
  74
  75     $self->clear_accepted_cache();
  76     $self->_set_compliance_mode(0x3);
  77 }
  78
  79 # Return true if bit set to examine Accept header
  80 sub accept_allowed {
  81     my $self = shift;
  82
  83     return $self->compliance_mode & 0x1;
  84 }
  85
  86 # Return true if bit set to examine Content-Type header
  87 sub content_type_allowed {
  88     my $self = shift;
  89
  90     return $self->compliance_mode & 0x2;
  91 }
  92
  93 # Private writer to set if we're looking at Accept or Content-Type headers
  94 sub _set_compliance_mode {
  95     my $self = shift;
  96     my $mode_bits = shift;
  97
  98     $self->compliance_mode($mode_bits);
  99 }
 100
 101 sub _build_accepted_content_types {
 102     my $self = shift;
 103
 104     my %types;
 105
 106     # First, we use the content type in the HTTP Request.  It wins all.
 107     # But only examine it if we're not in compliance mode or if we're
 108     # in deserializing mode
 109     $types{ $self->content_type } = 3
 110         if $self->content_type && $self->content_type_allowed();
 111
 112     # Seems backwards, but users are used to adding &content-type= to the uri to
 113     # define what content type they want to recieve back, in the equivalent Accept
 114     # header. Let the users do what they're used to, it's outside the RFC
 115     # specifications anyhow.
 116     if ($self->method eq "GET" && $self->param('content-type') && $self->accept_allowed()) {
 117         $types{ $self->param('content-type') } = 2;
 118     }
 119
 120     # Third, we parse the Accept header, and see if the client
 121     # takes a format we understand.
 122     # But only examine it if we're not in compliance mode or if we're
 123     # in serializing mode
 124     #
 125     # This is taken from chansen's Apache2::UploadProgress.
 126     if ( $self->header('Accept') && $self->accept_allowed() ) {
 127         $self->accept_only(1) unless keys %types;
 128
 129         my $accept_header = $self->header('Accept');
 130         my $counter       = 0;
 131
 132         foreach my $pair ( split_header_words($accept_header) ) {
 133             my ( $type, $qvalue ) = @{$pair}[ 0, 3 ];
 134             next if $types{$type};
 135
 136             # cope with invalid (missing required q parameter) header like:
 137             # application/json; charset="utf-8"
 138             # http://tools.ietf.org/html/rfc2616#section-14.1
 139             unless ( defined $pair->[2] && lc $pair->[2] eq 'q' ) {
 140                 $qvalue = undef;
 141             }
 142
 143             unless ( defined $qvalue ) {
 144                 $qvalue = 1 - ( ++$counter / 1000 );
 145             }
 146
 147             $types{$type} = sprintf( '%.3f', $qvalue );
 148         }
 149     }
 150
 151     [ sort { $types{$b} <=> $types{$a} } keys %types ];
 152 }
 153
 154 sub _build_preferred_content_type { $_[0]->accepted_content_types->[0] }
 155
 156 sub accepts {
 157     my $self = shift;
 158     my $type = shift;
 159
 160     return grep { $_ eq $type } @{ $self->accepted_content_types };
 161 }
 162
 163 1;
 164 __END__
 165
 166 =head1 NAME
 167
 168 Catalyst::TraitFor::Request::REST - A role to apply to Catalyst::Request giving it REST methods and attributes.
 169
 170 =head1 SYNOPSIS
 171
 172      if ( $c->request->accepts('application/json') ) {
 173          ...
 174      }
 175
 176      my $types = $c->request->accepted_content_types();
 177
 178 =head1 DESCRIPTION
 179
 180 This is a L<Moose::Role> applied to L<Catalyst::Request> that adds a few
 181 methods to the request object to facilitate writing REST-y code.
 182 Currently, these methods are all related to the content types accepted by
 183 the client and the content type sent in the request.
 184
 185 =head1 METHODS
 186
 187 =over
 188
 189 =item data
 190
 191 If the request went through the Deserializer action, this method will
 192 return the deserialized data structure.
 193
 194 =item accepted_content_types
 195
 196 Returns an array reference of content types accepted by the
 197 client.
 198
 199 The list of types is created by looking at the following sources:
 200
 201 =over 8
 202
 203 =item * Content-type header
 204
 205 If this exists, this will always be the first type in the list.
 206
 207 =item * content-type parameter
 208
 209 If the request is a GET request and there is a "content-type"
 210 parameter in the query string, this will come before any types in the
 211 Accept header.
 212
 213 =item * Accept header
 214
 215 This will be parsed and the types found will be ordered by the
 216 relative quality specified for each type.
 217
 218 =back
 219
 220 If a type appears in more than one of these places, it is ordered based on
 221 where it is first found.
 222
 223 =item preferred_content_type
 224
 225 This returns the first content type found. It is shorthand for:
 226
 227   $request->accepted_content_types->[0]
 228
 229 =item accepts($type)
 230
 231 Given a content type, this returns true if the type is accepted.
 232
 233 Note that this does not do any wildcard expansion of types.
 234
 235 =back
 236
 237 =head1 AUTHORS
 238
 239 See L<Catalyst::Action::REST> for authors.
 240
 241 =head1 LICENSE
 242
 243 You may distribute this code under the same terms as Perl itself.
 244
 245 =cut
 246