evil plugin

SQLTagging.pm

package Adama::Plugin::SQLTagging;

use Moo::Role;

require DBI;
require DBD::Pg;
require Class::Method::Modifiers;

# Ok so this only 'works' when using a blocking / forking server.  Even 
# then I wonder about it but we seem to get away with it.  This is probably 
# not going to work in a nonblocking or single process server.  Just fair
# notice. - JNAPIORKOWKI

my $request_id = "uninit";

around 'prepare' => sub {
  my ( $orig, $class, @arguments ) = @_;
  my $c = $orig->($class, @arguments);

  # Get the request id or a reasonable default;
  $request_id = $c->req->header('X-Client-ID') || 'not reported';

  # prevent SQL injection, although I'm pretty sure we totally control
  # the X-Client-ID (looks like 433dc646-5ab9-4c9f-9129-88075f21dd2c so we first
  # check for attempt to break the comment jail and then also whitelist only when
  # the value looks like a valid UUID

  if(
    ($request_id =~ m[\*/]) or
    ($request_id !~ m[^([[:xdigit:]]{8})-(?:[[:xdigit:]]{4}-){3}[[:xdigit:]]{12}$]) 
  ) {
    $request_id = 'CLEANED';
  }
  return $c;
};

# Basically this adds a request ID tag to all the SQL. So if the orignal SQL is
# 'select * from users' then iT ends up looking like:
# '/* X-Client-ID:'433dc646-5ab9-4c9f-9129-88075f21dd2c' */ select * from users'.
# This ends up in vivid cortext and we can then group SQL by request and then also
# link the SQL generated for a request to SumoLogic.

my $sql_tagger = sub {
  my ( $orig, $dbh, $sql, @args ) = @_;
  $sql = "/* X-Client-ID:'$request_id' */ $sql"
    unless $sql=~m[/\* X-Client-ID:]; # Tag the SQL unless its already tagged
  return $orig->($dbh, $sql, @args);
};

# Ok this is evil but quite possibly not irrational use case for why CMM lets you
# do this at all.  The only other way I can think of to get the requestID into
# the SQL would require tons of changes all over the code to call custom versions
# of a lot of core methods.  At least this is in one place and we can keep an eye
# on it.
#
# Basically $request ID is closed over and under the control of the Catalyst request
# response process.
#
# Might need to stick this in more places.  As far as I can
# see this covers most of what RDBO does but...

Class::Method::Modifiers::install_modifier( "DBD::_::db",
  around => ['prepare_cached'] => $sql_tagger);

Class::Method::Modifiers::install_modifier( "DBD::Pg::db",
  around => ['prepare'] => $sql_tagger);

1;