Amon2で簡単なGyazoサーバーを書いてみる

去年、Mojolicius::LiteでGyazoサーバーを書いたので、今年はAmon2で書いてみます。
普通のGyazoを作っても面白くないので、(独自に)短縮されたURLを返すようにしてみましょう。

% amon2-setup.pl Gyazo
...
 create mode 100644 tmpl/include/layout.tt
 create mode 100644 tmpl/include/pager.tt
 create mode 100644 tmpl/index.tt
 create mode 100644 xt/02_perlcritic.t
 create mode 100644 xt/03_pod.t

まずはsql/sqlite.sqlに追加します。

CREATE TABLE IF NOT EXISTS gyazo (
    image_key CHAR(6) PRIMARY KEY,
    url       TEXT
);

次にlib/Gyazo/Web/Dispatcher.pmを書き換えます。
アップロードされる画像は5MB以下、PNGフォーマットのみ対応することにしました。

package Gyazo::Web::Dispatcher;
use strict;
use warnings;
use Amon2::Web::Dispatcher::Lite;
use Digest::MD5 qw/md5_hex/;
use File::Spec;

post '/upload' => sub {
    my ($c) = @_;
    my $image = $c->req->upload('imagedata') // die;
    die unless $image->size < 5242880; # filesize is less than 5MB.

    my $imagedata = do {
        open my $fh, '<', $image->path or die $!;
        local $/; <$fh>;
    };
    die unless $imagedata =~ /^\x89PNG\x0d\x0a\x1a\x0a/; # .png format only.

    my $hash = md5_hex($imagedata);
    my $filename = File::Spec->catfile($c->base_dir, 'dat', "$hash.png");
    unless (-e $filename) {
        open my $fh, '>', $filename or die $!;
        print {$fh} $imagedata or die $!;
    }

    my $image_url = $c->req->base . "dat/$hash.png";

    my $key = sub {
        # dup check
        {
            my $key = $c->dbh->selectrow_array(q{
                SELECT image_key FROM gyazo WHERE url=? LIMIT 1
            }, {}, $image_url);
            return $key if $key;
        };
        # create new one.
        {
            my @chars = ( 'A'..'Z', 'a'..'z', '0'..'9' );
            my $key;
            for (1..6) {
                $key .= $chars[int rand @chars];
            }
            $c->dbh->do(q{INSERT INTO gyazo (image_key, url) VALUES (?, ?)}, {}, $key, $image_url);

            return $key;
        }
    }->();

    my $tiny_url = $c->req->base . $key;
    $c->create_response(200, [], [$tiny_url]);
};

get '/:key' => sub {
    my ($c, $args) = @_;

    my $image_url = $c->dbh->selectrow_array(q{
        SELECT url FROM gyazo WHERE image_key=? LIMIT 1
    }, {}, $args->{key});

    if ($image_url) {
        $c->redirect($image_url);
    } else {
        $c->res_404();
    }
};

1;

また、この場合デフォルトでロードしているプラグインが不要なので外しておきます。

diff --git a/lib/Gyazo/Web.pm b/lib/Gyazo/Web.pm
index 25fced9..62c38df 100644
--- a/lib/Gyazo/Web.pm
+++ b/lib/Gyazo/Web.pm
@@ -46,8 +46,6 @@ use Text::Xslate;
 
 # load plugins
 __PACKAGE__->load_plugins(
-    'Web::FillInFormLite',
-    'Web::CSRFDefender',
 );

/dat/XXX.pngで画像データにアクセスできるようにします。

diff --git a/app.psgi b/app.psgi
index 11605cc..fae7e52 100644
--- a/app.psgi
+++ b/app.psgi
@@ -19,7 +19,7 @@ use DBI;
 my $db_config = Gyazo->config->{DBI} || die "Missing configuration for DBI";
 builder {
     enable 'Plack::Middleware::Static',
-        path => qr{^(?:/static/)},
+        path => qr{^(?:/static/|/dat/)},
         root => File::Spec->catdir(dirname(__FILE__));
     enable 'Plack::Middleware::Static',
         path => qr{^(?:/robots\.txt|/favicon\.ico)$},

% mkdir dat
% plackup app.psgi
HTTP::Server::PSGI: Accepting connections at http://0:5000/

完成です！
これだけだと実際に使うときに面倒なので、アップロードスクリプトもどきを書いてみました。
Gyazo.appに同梱されていたscriptの必要な部分だけをPerlで書きなおしました。

use strict;
use warnings;
use autodie;
use File::Basename;
use File::Temp;
use LWP::UserAgent;

our $HOST = 'localhost:5000';
our $CGI  = '/upload';
our $UA   = 'Gyazo/1.0';

my $ua = LWP::UserAgent->new(agent => $UA);

my $tmpfile = File::Temp->new(SUFFIX => '.png');
my $imagefile = shift @ARGV;

if ($imagefile && -e $imagefile) {
    system qq{sips -s format png "$imagefile" --out "$tmpfile"};
} else {
    system qq{screencapture -i "$tmpfile"};
    if (-e $tmpfile) {
        system qq{sips -d profile --deleteColorManagementProperties "$tmpfile"};
    }
}

unless (-e $tmpfile) {
    exit;
}

my $res = $ua->post("http://$HOST$CGI",
    content_type => 'form-data',
    content => {
        imagedata => [$tmpfile->filename],
    },
);
die $res->status_line unless $res->is_success;

my $url = $res->content;
system "echo -n $url | pbcopy";
system "open $url";

enjoy :)