File Coverage

blib/lib/Plack/App/ImageMagick.pm

Criterion	Covered	Total	%
statement	12	14	85.7
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	18	20	90.0

package Plack::App::ImageMagick;
BEGIN {
  $Plack::App::ImageMagick::AUTHORITY = 'cpan:AJGB';
}
BEGIN {
  $Plack::App::ImageMagick::VERSION = '1.110990';
}
# ABSTRACT: Create and manipulate images with Image::Magick

use strict;
use warnings;

use parent qw( Plack::Component );

use Image::Magick;
use Plack::App::File;
use File::Spec ();
use JSON::XS ();
use Digest::MD5 ();
use Plack::Request;
use HTTP::Date ();
use Plack::Util ();
use String::Bash ();
use Try::Tiny;

use Plack::Util::Accessor qw(
    handler
    pre_process
    post_process
    apply
    with_query
    root
    cache_dir
);

my %replace_img_methods = map { $_ => 1 } qw(
    FlattenImage
);

my %push2stack_img_methods = map { $_ => 1 } qw(
    Clone
    EvaluateImages
    Fx
    Smush
    Transform
);

sub new {
    my $class = shift;

    my $self = $class->SUPER::new(@_);

    my $apply = $self->apply;
    my $handler = $self->handler;

    die "handler or apply is required"
        unless defined $handler || defined $apply;

    die "handler and apply are mutually exclusive"
        if defined $handler && defined $apply;

    die "with_query requires apply"
        if defined $self->with_query && ! defined $apply;

    die "pre/post processing methods are allowed only for apply option"
        if ! defined $apply && (
                defined $self->pre_process
                ||
                defined $self->post_process
            );

    die "apply should be non-empty array reference"
        if defined $apply && (
            ref $apply ne 'ARRAY'
            ||
            scalar @$apply == 0
        );


    return $self;
}

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

    my $request_uri = $env->{REQUEST_URI};

    # try loading from cache
    if ( $self->cache_dir ) {
        my $cached_file = File::Spec->catfile(
            $self->cache_dir,
            Digest::MD5::md5_hex( $request_uri )
        );

        if ( -r $cached_file ) {
            return $self->_create_response_from_cache( $env, $cached_file );
        }
    }

    my $handler;
    my $img = Image::Magick->new;

    if ( my $commands = $self->apply ) {

        # expand options from query string
        if ( my $with_query = $self->with_query ) {
            my $req = Plack::Request->new($env);
            my $encoded = JSON::XS::encode_json( $commands );

            my $query_params = $req->query_parameters;
            my $params = {};

            for my $param ( $query_params->keys ) {
                # use last value
                my $val = ($query_params->get_all($param))[-1];

                if ( $val ) {
                    # special chars forbidden
                    return http_response_403() unless $val =~ /\A[\w ]+\z/s;

                    $params->{ $param } = $val;
                };
            };

            # params expanded
            try {
                $commands = JSON::XS::decode_json( String::Bash::bash($encoded, $params) );
            } catch {
                warn "Parsing query failed: $_";
                return http_response_500();
            };
        }

        # create handler from commands
        $handler = sub {
            my ($app, $env, $img) = @_;

            unless ( ref $img eq 'Image::Magick' ) {
                warn "Invalid object $img, required Image::Magick";
                return http_response_500();
            }

            # working on existing image
            if ( my $img_root = $self->root ) {
                my $path = File::Spec->catfile( $img_root, $env->{PATH_INFO} );
                my $err = $img->Read( $path );
                if ( "$err" ) {
                    warn "Read($path) failed: $err";
                    return http_response_404();
                }
            }

            for (my $i = 0; $i < @$commands; $i += 2 ) {
                my ($method, $args) = @{ $commands }[ $i .. $i + 1 ];

                my @opts;
                if ( ref $args eq 'HASH' ) {
                    @opts = %$args;
                } elsif ( ref $args eq 'ARRAY' ) {
                    @opts = @$args;
                }

                unless ( $method ) {
                    warn "Undefined method at index: $i";
                    return http_response_500();
                }
                my $x = $img->$method( @opts );

                if ( exists $push2stack_img_methods{ $method } ) {
                    unless ( ref $x ) {
                        warn "$method(@opts) failed: $x";
                        return http_response_500();
                    };
                    push @$img, $x;
                } elsif ( exists $replace_img_methods{ $method } ) {
                    unless ( ref $x ) {
                        warn "$method(@opts) failed: $x";
                        return http_response_500();
                    };

                    $img = $x;
                } elsif ( "$x" ) {
                    warn "$method(@opts) failed: $x";
                    return http_response_500();
                }
            }
            return $img;
        };
    } else {
        $handler = $self->handler;
    };

    if ( defined $handler ) {

        if ( my $pre_process = $self->pre_process ) {
            $img = $pre_process->($self, $env, $img);

            unless ( ref $img eq 'Image::Magick' ) {
                warn "Invalid object $img, required Image::Magick";
                return http_response_500();
            }
        }

        if ( my $out = $handler->($self, $env, $img) ) {
            if ( ref $out ne 'Image::Magick' ) {
                return $out;
            }

            if ( my $post_process = $self->post_process ) {
                $out = $post_process->($self, $env, $out);

                unless ( ref $out eq 'Image::Magick' ) {
                    warn "Invalid object $out, required Image::Magick";
                    return http_response_500();
                }

            }

            # flatten image before rendering
            if ( @$out > 1 ) {
                $out = $out->FlattenImage();
                unless ( ref $out ) {
                    warn "FlattenImage() failed: $out";
                    return http_response_500();
                };
            }

            my $res;
            if ( $self->cache_dir ) {
                my $cached_file = File::Spec->catfile(
                    $self->cache_dir,
                    Digest::MD5::md5_hex( $request_uri )
                );

                my $x = $out->Write( filename => $cached_file );
                if ( "$x" ) {
                    warn "Write($cached_file) failed: $x";
                    return http_response_500();
                };

                # serve via Plack::App::File, so middleware like XSendfile
                # can be used
                $res = $self->_create_response_from_cache(
                    $env, $cached_file, $out->Get('mime')
                );
            } else {
                # use image blob as body
                $res = $self->_create_response_from_img( $out );
            }

            undef $out;
            return $res;
        }
    }

    # we are supposed to do something
    return http_response_500();
}

sub _create_response_from_cache {
    my ($self, $env, $file_path, $content_type) = @_;

    # discover content type from cached file
    unless ( $content_type ) {
        my $img = Image::Magick->new;
        my $format = ($img->Ping( $file_path ))[3];
        $content_type = $img->MagickToMime( $format );
    };


    my $file_app = Plack::App::File->new(
        file => $file_path,
        content_type => $content_type,
    );

    local $env->{PATH_INFO} = $file_path;
    return $file_app->call( $env );
};

sub _create_response_from_img {
    my ($self, $img) = @_;

    my $data = join('', $img->ImageToBlob);

    return [
        200,
        [
            'Content-Type' => $img->Get('mime'),
            'Content-Length' => length $data,
            # be proxy friendly
            'Last-Modified'  => HTTP::Date::time2str( time ),
        ],
        [ $data ]
    ];
}


# in case someone wants pretty error messages in subclasses those are public
sub http_response_403 {
    my $self = shift;

    return [ 403,
        [
            'Content-Type' => 'text/plain',
            'Content-Length' => 12,
        ],
        [ '403 Forbidden' ]
    ]
}

sub http_response_404 {
    my $self = shift;

    return [ 404,
        [
            'Content-Type' => 'text/plain',
            'Content-Length' => 12,
        ],
        [ '404 Not Found' ]
    ]
}

sub http_response_500 {
    my $self = shift;

    return [ 500,
        [
            'Content-Type' => 'text/plain',
            'Content-Length' => 22,
        ],
        [ '500 Service Unavailable' ]
    ]
}

1;

__END__