Change to have a 'serializer' attribute on the controller, and coerce a new Data...
[catagits/Catalyst-Engine-STOMP.git] / lib / Catalyst / Controller / MessageDriven.pm
1 package Catalyst::Controller::MessageDriven;
2 use Moose;
3 use Data::Serializer;
4 use Moose::Util::TypeConstraints;
5 use MooseX::Types::Moose qw/Str/;
6 use namespace::autoclean;
7
8 BEGIN { extends 'Catalyst::Controller' }
9
10 =head1 NAME
11
12 Catalyst::Controller::MessageDriven
13
14 =head1 SYNOPSIS
15
16   package MyApp::Controller::Queue;
17   use Moose;
18   BEGIN { extends 'Catalyst::Controller::MessageDriven' }
19
20   sub some_action : Local {
21       my ($self, $c, $message) = @_;
22
23       # Handle message
24
25       # Reply with a minimal response message
26       my $response = { type => 'testaction_response' };
27       $c->stash->{response} = $response;
28   }
29
30 =head1 DESCRIPTION
31
32 A Catalyst controller base class for use with Catalyst::Engine::Stomp,
33 which handles YAML-serialized messages. A top-level "type" key in the
34 YAML determines the action dispatched to.
35
36 =head1 METHODS
37
38 =head2 begin
39
40 Deserializes the request into C<< $c->stash->{request} >>
41
42 =head2 default
43
44 Dispatches to method named by the key C<< $c->stash->{request}->{type} >>
45
46 =head2 end
47
48 Serializes the response from C<< $c->stash->{response} >>
49
50 =cut
51
52 class_type 'Data::Serializer';
53 my $serializer_t = subtype 'Data::Serializer';
54 coerce $serializer_t, from 'Str',
55     via { Data::Serializer->new( serializer => $_ ) };
56
57 has serializer => (
58     isa => $serializer_t, is => 'ro', required => 1,
59     default => 'YAML', coerce => 1,
60 );
61
62 sub begin : Private {
63     my ($self, $c) = @_;
64
65     # Deserialize the request message
66         my $message;
67     my $s = $self->serializer;
68     eval {
69         my $body = $c->request->body;
70         open my $IN, "$body" or die "can't open temp file $body";
71         $message = $s->raw_deserialize(do { local $/; <$IN> });
72     };
73     if ($@) {
74         # can't reply - reply_to is embedded in the message
75         $c->error("exception in deserialize: $@");
76     }
77     else {
78         $c->stash->{request} = $message;
79     }
80 }
81
82 sub end : Private {
83     my ($self, $c) = @_;
84
85     # Engine will send our reply based on the value of this header.
86     $c->response->headers->header( 'X-Reply-Address' => $c->stash->{request}->{reply_to} );
87
88     # The wire response
89     my $output;
90
91     # Load a serializer
92     my $s = $self->serializer;
93
94     # Custom error handler - steal errors from catalyst and dump them into
95     # the stash, to get them serialized out as the reply.
96      if (scalar @{$c->error}) {
97         $c->log->error($_) for @{$c->error}; # Log errors in Catalyst
98         my $error = join "\n", @{$c->error};
99         $c->stash->{response} = { status => 'ERROR', error => $error };
100         $output = $s->serialize( $c->stash->{response} );
101         $c->clear_errors;
102         $c->response->status(400);
103      }
104
105     # Serialize the response
106     eval {
107         $output = $s->raw_serialize( $c->stash->{response} );
108     };
109     if ($@) {
110          my $error = "exception in serialize: $@";
111          $c->stash->{response} = { status => 'ERROR', error => $error };
112          $output = $s->serialize( $c->stash->{response} );
113         $c->response->status(400);
114     }
115
116     $c->response->output( $output );
117 }
118
119 sub default : Private {
120     my ($self, $c) = @_;
121
122     # Forward the request to the appropriate action, based on the
123     # message type.
124     my $action = $c->stash->{request}->{type};
125     if (defined $action) {
126         $c->forward($action, [$c->stash->{request}]);
127     }
128     else {
129          $c->error('no message type specified');
130     }
131 }
132
133 __PACKAGE__->meta->make_immutable;
134