lib/SGN/View/Email/ErrorEmail.pm

   1 package SGN::View::Email::ErrorEmail;
   2 use Moose;
   3 use Moose::Util::TypeConstraints;
   4
   5 use Data::Dump ();
   6 use Data::Visitor::Callback;
   7
   8 use Socket;
   9
  10 =head1 NAME
  11
  12 SGN::View::Email::ErrorEmail - Email View for SGN
  13
  14 =head1 DESCRIPTION
  15
  16 View for sending error emails from SGN.  Errors to email should be an
  17 arrayref of strings in C<$c-E<gt>stash-E<gt>{email_errors}>.
  18
  19 =cut
  20
  21 BEGIN { extends 'SGN::View::Email' }
  22
  23 before 'process' => sub {
  24     my ($self, $c) = @_;
  25
  26     # convert the notify_errors stash key into an email stash key for
  27     # the generic email view
  28     $c->stash->{email} = $self->make_email( $c );
  29
  30     $c->log->debug('sending error email to '.$c->stash->{email}->{to}) if $c->debug;
  31 };
  32
  33 =head1 ATTRIBUTES
  34
  35 =head2 debug_filter_visitor
  36
  37 The L<Data::Visitor::Callback> object being used for filtering.  Can
  38 be replaced with your own L<Data::Visitor> subclass if desired.
  39
  40 =cut
  41
  42 has 'debug_filter_visitor' => (
  43     is => 'rw',
  44     isa => 'Data::Visitor',
  45     lazy_build => 1,
  46    );
  47 sub _build_debug_filter_visitor {
  48     my ($self) = @_;
  49
  50     return Data::Visitor::Callback->new(
  51
  52         # descend into objects also
  53         object => 'visit_ref',
  54
  55         # render skip_class option as visitor args
  56         ( map {
  57             my $class = $_;
  58             $class => sub { shift; '('.ref(shift)." object skipped, isa $class)" }
  59          } @{ $self->dump_skip_class }
  60         ),
  61
  62         #render any other visitor args
  63         %{ $self->dump_visitor_args },
  64
  65        );
  66 }
  67
  68 =head2 dump_skip_class
  69
  70 One or more class names to filter out of objects to be dumped.  If an
  71 object is-a one of these classes, the dump filtering will replace
  72 the object with a string "skipped" message.
  73
  74 Can be either an arrayref or a whitespace-separated list of class names.
  75
  76 Default: "Catalyst", which will filter out Catalyst context objects.
  77
  78 =cut
  79
  80 { my $sc = subtype as 'ArrayRef';
  81   coerce $sc, from 'Str', via { [ split ] };
  82   has 'dump_skip_class' => (
  83     is      => 'ro',
  84     isa     => $sc,
  85     coerce  => 1,
  86     default => sub { ['Catalyst'] },
  87    );
  88 }
  89
  90 =head2 dump_visitor_args
  91
  92 Hashref of additional constructor args passed to the
  93 L<Data::Visitor::Callback> object used to filter the objects for
  94 dumping.  Can be used to introduce nearly any kind of additional
  95 filtering desired.
  96
  97 Example:
  98
  99    # replace all scalar values in dumped objects with "chicken"
 100    DebugFilter => {
 101       visitor_args => {
 102          value => sub { 'Chicken' },
 103       },
 104    }
 105
 106 =cut
 107
 108 has 'dump_visitor_args' => (
 109     is      => 'ro',
 110     isa     => 'HashRef',
 111     default => sub { {} },
 112 );
 113
 114 =head2 reverse_dns
 115
 116 Boolean, default true.
 117
 118 If set, attempts to do a reverse DNS lookup to
 119 resolve the hostname of the client.
 120
 121 =cut
 122
 123 has 'reverse_dns' => (
 124     is      => 'ro',
 125     isa     => 'Bool',
 126     default => 1,
 127    );
 128
 129 =head1 METHODS
 130
 131 =head2 make_email( $c )
 132
 133 Returns a hashref of error email information, suitable for rendering
 134 with L<Catalyst::View::Email>.
 135
 136 =cut
 137
 138 sub make_email {
 139     my ( $self, $c ) = @_;
 140     my $error_num = 1;
 141
 142     my $type = ( grep $_->is_server_error, @{$c->stash->{email_errors}} ) ? 'E' : 'NB';
 143
 144     my $subject = '['.$c->config->{name}."]($type) ".$c->req->uri->path_query;
 145     # clamp the subject line to be no longer than 115 chars
 146     $subject = substr( $subject, 0, 110 ).'...' if 115 < length $subject;
 147
 148     my $body = join '',
 149         # the errors
 150         "==== Error(s) ====\n\n",
 151         ( map { $error_num++.".  $_\n" } @{$c->stash->{email_errors}} ),
 152
 153         # all the necessary debug information
 154         ( map { ("\n==== $_->[0] ====\n\n", $_->[1], "\n") } $self->dump_these_strings( $c ) );
 155
 156     return {
 157         to      => $self->default->{to},
 158         from    => $self->default->{from},
 159         subject => $subject,
 160         body    => $body,
 161     };
 162
 163 }
 164
 165
 166 =head2 dump_these_strings( $c )
 167
 168 Get a list like
 169 C<['Request', 'string dump'], ['Stash', 'string dump'], ...>
 170 for use in debugging output.
 171
 172 These are filtered, suitable for debugging output.
 173
 174 =cut
 175
 176 sub dump_these_strings {
 177     my ($self,$c) = @_;
 178     return
 179         [ 'Summary', $self->summary_text( $c ) ],
 180         map [ $_->[0], Data::Dump::dump( $self->filter_object_for_dump( $_->[1] ) ) ],
 181         $c->dump_these;
 182 }
 183
 184 # SGN-specific filtering, removing db passwords and cookie encryption
 185 # strings from error email output
 186 around 'dump_these_strings' => sub {
 187     my $orig = shift;
 188     my $self = shift;
 189     my ($c) = @_;
 190
 191     my @ret = $self->$orig(@_);
 192
 193     my @remove_strings =
 194         map  { Data::Dump::dump( $_ ) }
 195         grep { $_ }
 196         (
 197             @{$c->config}{qw{ cookie_encryption_key dbpass }},
 198             ( map $_->{password}, values %{$c->config->{DatabaseConnection} || {}} ),
 199         );
 200
 201     for my $ret ( @ret ) {
 202         for my $redact ( @remove_strings ) {
 203             $ret->[1] =~ s/$redact/"<redacted>"/g;
 204         }
 205     }
 206
 207     return @ret;
 208 };
 209
 210
 211 =head2 filter_object_for_dump( $object )
 212
 213 Return a filtered copy of the given object.
 214
 215 =cut
 216
 217 sub filter_object_for_dump {
 218     my ( $self, $object ) = @_;
 219     $self->debug_filter_visitor->visit( $object );
 220 }
 221
 222 =head2 summary_text( $c )
 223
 224 Get an un-indented block of text of the most salient features of the
 225 error.  Example:
 226
 227   Path_Query: /path/to/request?foo=bar&baz=boo
 228   Process ID: <PID of the serving process>
 229   User-Agent: <user agent string>
 230   Referrer:   <referrer string>
 231
 232 =cut
 233
 234 sub summary_text {
 235     my ( $self, $c ) = @_;
 236
 237     my @client_ips = $c->req->header('X-Forwarded-For')
 238                    ? ( map { split /\s*,\s*/, $_ } $c->req->header('X-Forwarded-For') )
 239                    : ( $c->req->address );
 240     my $client_addr_string = join ', ', (
 241         $self->reverse_dns
 242             ? ( map {
 243                   my $client_ip = $_;
 244                   "$client_ip (".(gethostbyaddr( inet_aton( $client_ip ), AF_INET ) || 'reverse DNS lookup failed').')'
 245                 } @client_ips
 246               )
 247             : @client_ips
 248       );
 249
 250     no warnings 'uninitialized';
 251     return join '', map "$_\n", (
 252       'Request    : '.$c->req->method.' '.$c->req->uri,
 253       'User-Agent : '.$c->req->user_agent,
 254       'Referrer   : '.$c->req->referer,
 255       'Client Addr: '.$client_addr_string,
 256       'Worker PID : '.$$,
 257      );
 258 }
 259
 260 =head1 AUTHOR
 261
 262 Robert Buels
 263
 264 =cut
 265
 266 1;