File Coverage

blib/lib/Plack/Middleware/DebugLogging.pm

Criterion	Covered	Total	%
statement	123	150	82.0
branch	50	96	52.0
condition	13	27	48.1
subroutine	26	29	89.6
pod	8	11	72.7
total	220	313	70.2

package Plack::Middleware::DebugLogging;
$Plack::Middleware::DebugLogging::VERSION = '0.001004';
# ABSTRACT: Catalyst style console debugging for plack apps

use strict;
use warnings;

use Data::Dumper::Concise;
use Data::Serializer::Raw;
use Module::Runtime qw(use_module);
use Text::SimpleTable;
use Plack::Request;
use Plack::Response;
use Term::Size::Any;
use Try::Tiny;
use Plack::Util::Accessor qw(debug request response request_headers request_parameters
                             response_headers  response_status_line keywords uploads
                             body_params query_params logger logger_override term_width
                             attempt_deserialize serializer);

use parent qw/Plack::Middleware/;

sub prepare_app {
    my ($self) = @_;

    $self->debug(1) unless defined $self->debug;
    $self->request(1) unless defined $self->request;
    $self->response(1) unless defined $self->response;
    $self->keywords(1) unless defined $self->keywords;
    $self->request_headers(1) unless defined $self->request_headers;
    $self->request_parameters(1) unless defined $self->request_parameters;
    $self->response_headers(1) unless defined $self->response_headers;
    $self->response_status_line(1) unless defined $self->response_status_line;
    $self->uploads(1) unless defined $self->uploads;
    $self->body_params(1) unless defined $self->body_params;
    $self->query_params(1) unless defined $self->query_params;
    $self->attempt_deserialize(1) unless defined $self->attempt_deserialize;

    if ($self->attempt_deserialize) {
        $self->serializer(Data::Serializer::Raw->new);
    }

    $self->logger_override(1) if defined $self->logger;
}

sub call {
    my($self, $env) = @_;

    my $request = Plack::Request->new($env);

    # take latest $request->logger unless it was explicitly provided at build time
    if (!$self->logger_override) {
        if ($request->logger) {
            $self->logger($request->logger);
        }
        else {
            $self->logger(sub {
                my ($args) = @_;
                print STDERR $args->{message};
            });
        }
    }

    $self->log_request($request) if $self->request;

    $self->response_cb($self->app->($env), sub {
        my $res = Plack::Response->new(@{shift()});
        $self->log_response($res) if $self->response;
        $res;
    });
}

sub log {
    my ($self, $msg) = @_;

    if (my $logger = $self->logger) {
        $logger->({ level => 'debug', message => "$msg\n" });
    }
    else {
        print STDERR $msg;
    }
}


sub log_request {
    my ($self, $request) = @_;

    return unless $self->debug;

    my ( $method, $path, $address ) = ( $request->method, $request->path, $request->address );
    $method ||= '';
    $path = '/' unless length $path;
    $address ||= '';
    $self->log(qq/"$method" request for "$path" from "$address"/);

    $self->log_headers('request', $request->headers)
        if $self->request_headers;

    if ( index( $request->env->{QUERY_STRING}, '=' ) < 0 ) {
        my $keywords = $self->unescape_uri($request->env->{QUERY_STRING});
        $self->log("Query keywords are: $keywords\n")
            if $keywords && $self->keywords;
    }

    if ($self->request_parameters) {
        $self->log_request_parameters(query => $request->query_parameters->mixed)
            if $self->query_params;

        $self->log_request_parameters(body => $request->body_parameters->mixed)
            if $request->content && $self->body_params;

        $self->log_request_parameters(encoded => $request)
            if $request->content && ($request->content_type || '') !~ m/www-form-urlencoded/;
    }

    $self->log_request_uploads($request) if $self->uploads;
}



sub log_response {
    my ($self, $response) = @_;

    return unless $self->debug;

    $self->log_response_status_line($response) if $self->response_status_line;
    $self->log_headers('response', $response->headers) if $self->response_headers;
}


sub log_response_status_line {
    my ($self, $response) = @_;

    $self->log(
        sprintf(
            'Response Code: %s; Content-Type: %s; Content-Length: %s',
            $response->code                              || 'unknown',
            $response->headers->header('Content-Type')   || 'unknown',
            $response->headers->header('Content-Length') || 'unknown'
        )
    );
}


our $module_map = {
    'text/xml'           => 'XML::Simple',
    'text/x-yaml'        => 'YAML',
    'application/json'   => 'JSON',
    'text/x-json'        => 'JSON',
    'text/x-data-dumper' => 'Data::Dumper',
    'text/x-data-denter' => 'Data::Denter',
    'text/x-data-taxi'   => 'Data::Taxi',
    'application/x-storable' => 'Storable',
    'application/x-freezethaw' => 'FreezeThaw',
    'text/x-config-general' => 'Config::General',
    'text/x-php-serialization' => 'PHP::Serialization'
};

sub log_request_parameters {
    my $self = shift;
    my %all_params = @_;

    return unless $self->debug;

    my $column_width = $self->_term_width() - 44;
    foreach my $type (qw(query body)) {
        my $params = $all_params{$type};
        next if ! keys %$params;
        my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] );
        for my $key ( sort keys %$params ) {
            my @param = $params->{$key};
            my $value = length($param[0]) ? $param[0] : '';
            $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
        }
        $self->log( ucfirst($type) . " Parameters are:\n" . $t->draw );
    }

    if (my $request = $all_params{encoded}) {
        if (my $module = $module_map->{$request->content_type}) {
            # if the module is not installed let Data::Serializer propogate the module load fail.
            try {
                $self->serializer->serializer($module);
                my $decoded = $self->serializer->deserialize($request->content);
                $self->log($request->content_type . " encoded body parameters are:\n" . Dumper($decoded));
            }
            catch {
                $self->log($request->content_type . " failed to deserialize: $_");
            };
        } else {
            $self->log('Unrecognized Content-Type: ' .$request->content_type);
        }
    }
}


sub log_request_uploads {
    my ($self, $request) = @_;

    return unless $self->debug;

    my $uploads = $request->uploads;
    if ( keys %$uploads ) {
        my $t = Text::SimpleTable->new(
            [ 12, 'Parameter' ],
            [ 26, 'Filename' ],
            [ 18, 'Type' ],
            [ 9,  'Size' ]
        );
        for my $key ( sort keys %$uploads ) {
            my $upload = $uploads->{$key};
            for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
                $t->row( $key, $u->filename, $u->type, $u->size );
            }
        }
        $self->log( "File Uploads are:\n" . $t->draw );
    }
}


sub log_headers {
    my ($self, $type, $headers) = @_;

    return unless $self->debug;

    my $column_width = $self->_term_width() - 28;
    my $t = Text::SimpleTable->new( [ 15, 'Header Name' ], [ $column_width, 'Value' ] );
    $headers->scan(
        sub {
            my ( $name, $value ) = @_;
            $t->row( $name, $value );
        }
    );
    $self->log( ucfirst($type) . " Headers:\n" . $t->draw );
}

sub env_value {
    my ( $class, $key ) = @_;

    $key = uc($key);
    my @prefixes = ( class2env($class), 'PLACK' );

    for my $prefix (@prefixes) {
        if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
            return $value;
        }
    }

    return;
}

sub _term_width {
    my ($self) = @_;

    return $self->term_width if $self->term_width;

    my $width = eval '
        my ($columns, $rows) = Term::Size::Any::chars;
        return $columns;
    ';

    if ($@) {
        $width = $ENV{COLUMNS}
            if exists($ENV{COLUMNS})
            && $ENV{COLUMNS} =~ m/^\d+$/;
    }

    $width = 80 unless ($width && $width >= 80);
    return $width;
}

sub unescape_uri {
    my ( $self, $str ) = @_;

    $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;

    return $str;
}

1;

__END__