lib/Catalyst/TraitFor/Request/REST.pm

   1 package Catalyst::TraitFor::Request::REST;
   2 use Moose::Role;
   3 use HTTP::Headers::Util qw(split_header_words);
   4 use namespace::autoclean;
   5
   6 our $VERSION = '0.90';
   7 $VERSION = eval $VERSION;
   8
   9 has [qw/ data accept_only /] => ( is => 'rw' );
  10
  11 has accepted_content_types => (
  12     is       => 'ro',
  13     isa      => 'ArrayRef',
  14     lazy     => 1,
  15     builder  => '_build_accepted_content_types',
  16     init_arg => undef,
  17 );
  18
  19 has preferred_content_type => (
  20     is       => 'ro',
  21     isa      => 'Str',
  22     lazy     => 1,
  23     builder  => '_build_preferred_content_type',
  24     init_arg => undef,
  25 );
  26
  27 has accepted_response_content_types => (
  28     is       => 'ro',
  29     isa      => 'ArrayRef',
  30     lazy     => 1,
  31     builder  => '_build_accepted_response_content_types',
  32     init_arg => undef,
  33 );
  34
  35 has preferred_response_content_type => (
  36     is       => 'ro',
  37     isa      => 'Str',
  38     lazy     => 1,
  39     builder  => '_build_preferred_response_content_type',
  40     init_arg => undef,
  41 );
  42
  43 sub _accepted_types_sort {
  44     my ($self, %types) = @_;
  45     [ sort { $types{$b} <=> $types{$a} } keys %types ];
  46 }
  47
  48 sub _build_accepted_content_types {
  49     my $self = shift;
  50     my %types = $self->_accepted_response_content_types_inner;
  51     # First, we use the content type in the HTTP Request.  It wins all.
  52     $types{ $self->content_type } = 3
  53         if $self->content_type;
  54     $self->_accepted_types_sort(%types);
  55 }
  56
  57 sub _build_accepted_response_content_types {
  58     my $self = shift;
  59     my %types = $self->_accepted_response_content_types_inner;
  60     $self->_accepted_types_sort(%types);
  61 }
  62
  63 sub _accepted_response_content_types_inner {
  64     my $self = shift;
  65
  66     my %types;
  67
  68     if ($self->method eq "GET" && $self->param('content-type')) {
  69         $types{ $self->param('content-type') } = 2;
  70     }
  71
  72     # Third, we parse the Accept header, and see if the client
  73     # takes a format we understand.
  74     #
  75     # This is taken from chansen's Apache2::UploadProgress.
  76     if ( $self->header('Accept') ) {
  77         $self->accept_only(1) unless keys %types;
  78
  79         my $accept_header = $self->header('Accept');
  80         my $counter       = 0;
  81
  82         foreach my $pair ( split_header_words($accept_header) ) {
  83             my ( $type, $qvalue ) = @{$pair}[ 0, 3 ];
  84             next if $types{$type};
  85
  86             # cope with invalid (missing required q parameter) header like:
  87             # application/json; charset="utf-8"
  88             # http://tools.ietf.org/html/rfc2616#section-14.1
  89             unless ( defined $pair->[2] && lc $pair->[2] eq 'q' ) {
  90                 $qvalue = undef;
  91             }
  92
  93             unless ( defined $qvalue ) {
  94                 $qvalue = 1 - ( ++$counter / 1000 );
  95             }
  96
  97             $types{$type} = sprintf( '%.3f', $qvalue );
  98         }
  99     }
 100
 101     %types;
 102 }
 103
 104 sub _build_preferred_content_type { $_[0]->accepted_content_types->[0] }
 105
 106 sub _build_preferred_response_content_type { $_[0]->accepted_response_content_types->[0] }
 107
 108 sub accepts {
 109     my $self = shift;
 110     my $type = shift;
 111
 112     return grep { $_ eq $type } @{ $self->accepted_content_types };
 113 }
 114
 115 1;
 116 __END__
 117
 118 =head1 NAME
 119
 120 Catalyst::TraitFor::Request::REST - A role to apply to Catalyst::Request giving it REST methods and attributes.
 121
 122 =head1 SYNOPSIS
 123
 124      if ( $c->request->accepts('application/json') ) {
 125          ...
 126      }
 127
 128      my $types = $c->request->accepted_content_types();
 129
 130 =head1 DESCRIPTION
 131
 132 This is a L<Moose::Role> applied to L<Catalyst::Request> that adds a few
 133 methods to the request object to facilitate writing REST-y code.
 134 Currently, these methods are all related to the content types accepted by
 135 the client.
 136
 137 =head1 METHODS
 138
 139 =over
 140
 141 =item data
 142
 143 If the request went through the Deserializer action, this method will
 144 return the deserialized data structure.
 145
 146 =item accepted_content_types
 147
 148 Returns an array reference of content types accepted by the
 149 client.
 150
 151 The list of types is created by looking at the following sources:
 152
 153 =over 8
 154
 155 =item * Content-type header
 156
 157 If this exists, this will always be the first type in the list.
 158
 159 =item * content-type parameter
 160
 161 If the request is a GET request and there is a "content-type"
 162 parameter in the query string, this will come before any types in the
 163 Accept header.
 164
 165 =item * Accept header
 166
 167 This will be parsed and the types found will be ordered by the
 168 relative quality specified for each type.
 169
 170 =back
 171
 172 If a type appears in more than one of these places, it is ordered based on
 173 where it is first found.
 174
 175 =item preferred_content_type
 176
 177 This returns the first content type found. It is shorthand for:
 178
 179   $request->accepted_content_types->[0]
 180
 181 =item accepts($type)
 182
 183 Given a content type, this returns true if the type is accepted.
 184
 185 Note that this does not do any wildcard expansion of types.
 186
 187 =back
 188
 189 =head1 AUTHORS
 190
 191 See L<Catalyst::Action::REST> for authors.
 192
 193 =head1 LICENSE
 194
 195 You may distribute this code under the same terms as Perl itself.
 196
 197 =cut
 198