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