File Coverage

blib/lib/Plack/Middleware/Recorder.pm

Criterion	Covered	Total	%
statement	104	113	92.0
branch	25	32	78.1
condition	2	5	40.0
subroutine	18	18	100.0
pod	3	3	100.0
total	152	171	88.8

## no critic (RequireUseStrict)
package Plack::Middleware::Recorder;
$Plack::Middleware::Recorder::VERSION = '0.05'; # TRIAL
## use critic (RequireUseStrict)
use strict;
use warnings;
use parent 'Plack::Middleware';

use Carp qw(croak);
use HTTP::Request;
use IO::File;
use IO::String;
use Sereal qw(encode_sereal);
use Fcntl qw(:flock);
use Scope::Guard;
use namespace::clean;

use Plack::Util::Accessor qw/active start_url stop_url/;

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

    $self->active(1)                    unless defined $self->active;
    $self->start_url('/recorder/start') unless defined $self->start_url;
    $self->stop_url('/recorder/stop')   unless defined $self->stop_url;

    my $output = delete $self->{'output'};
    croak "output parameter required" unless defined $output;

    if (ref $output) {
        $self->{'output_fh'} = $output;
        $output->autoflush(1);
    } else {
        unless(-w $output) {
            croak "$output is not writable";
        }
        $self->{'output_filename'} = $output;
    }
}

sub _output_fh {
    my ( $self, $env ) = @_;
    unless ($self->{'output_fh'}) {
        my $mode = $env->{'psgi.run_once'} ? 'a' : 'w';
        $self->{'output_fh'} = IO::File->new($self->{'output_filename'}, $mode);
        $self->{'output_fh'}->autoflush(1);
    }
    return $self->{'output_fh'};
}

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

    my $request = HTTP::Request->new;
    $request->method($env->{'REQUEST_METHOD'});
    $request->uri($env->{'REQUEST_URI'});
    $request->header(Content_Length => $env->{'CONTENT_LENGTH'});
    $request->header(Content_Type   => $env->{'CONTENT_TYPE'});
    foreach my $header (grep { /^HTTP_/ } keys %$env) {
        my $value = $env->{$header};
        $header   =~ s/^HTTP_//;
        $header   = uc($header);
        $header   =~ s/\b([a-z])/uc $!/ge;

        $request->header($header, $value);
    }

    my $input  = $env->{'psgi.input'};
    my $body   = IO::String->new;
    my $buffer = '';
    while($input->read($buffer, 1024) > 0) {
        print $body $buffer;
    }

    $body->setpos(0);
    $env->{'psgi.input'} = $body;
    $request->content(${ $body->string_ref });

    return $request;
}

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

    my $app       = $self->app;
    my $start_url = $self->start_url;
    my $stop_url  = $self->stop_url;
    my $path      = $env->{'PATH_INFO'};

    $env->{__PACKAGE__ . '.start_url'} = $start_url;
    $env->{__PACKAGE__ . '.stop_url'}  = $stop_url;

    if($path =~ m!\Q$start_url\E!) {
        $self->active(1);
        $env->{__PACKAGE__ . '.active'} = $self->active;
        return [
            200,
            ['Content-Type' => 'text/plain'],
            [ 'Request recording is ON' ],
        ];
    } elsif($path =~ m!\Q$stop_url\E!) {
        $self->active(0);
        $env->{__PACKAGE__ . '.active'} = $self->active;
        return [
            200,
            ['Content-Type' => 'text/plain'],
            [ 'Request recording is OFF' ],
        ];
    } elsif($self->active) {
        my $req    = $self->env_to_http_request($env);
        my $frozen = encode_sereal($req);

        my $fh = $self->_output_fh($env);
        # $guard looks unused, but it's unlocking the file upon its
        # destruction
        my $guard = $self->_create_concurrency_lock($fh, $env);
        if($guard) {
            $fh->write(pack('Na*', length($frozen), $frozen));
            $fh->flush;
        }
    }

    $env->{__PACKAGE__ . '.active'} = $self->active;

    return $app->($env);
}

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

    return 1 if !$env->{'psgi.multithread'} && !$env->{'psgi.multiprocess'};

    my $locked = eval { flock($fh, LOCK_EX) || die "$!\n" };

    if(!$locked) {
        if(my $log = $env->{'psgix.logger'}) {
            my $error = $@ || 'Unknown error';
            chomp $error;

            $log->({
                level   => 'warn',
                message => "Unable to lock filehandle in multiprocess environment ($error); skipping recording",
            });
        }
        return;
    }

    return Scope::Guard->new( sub { flock($fh, LOCK_UN) });
}

1;

# ABSTRACT: Plack middleware that records your client-server interactions

__END__