File Coverage

blib/lib/Web/Paste/Simple.pm

Criterion	Covered	Total	%
statement	41	73	56.1
branch	0	14	0.0
condition	0	7	0.0
subroutine	14	22	63.6
pod	6	6	100.0
total	61	122	50.0

package Web::Paste::Simple;

use 5.010;
use Moo;
use MooX::Types::MooseLike::Base qw( Str CodeRef ArrayRef InstanceOf );
use Carp qw( confess );
use JSON qw( from_json to_json );
use HTML::HTML5::Entities qw( encode_entities_numeric );
use constant read_only => 'ro';
use aliased 'Text::Template';
use aliased 'Data::UUID';
use aliased 'Plack::Request';
use aliased 'Plack::Response';
use aliased 'Path::Class::Dir';
use aliased 'Path::Class::File';

BEGIN {
	$Web::Paste::Simple::AUTHORITY = 'cpan:TOBYINK';
	$Web::Paste::Simple::VERSION   = '0.002';
}

has uuid_gen => (
	is      => read_only,
	isa     => InstanceOf[UUID],
	default => sub { UUID->new },
);

has template => (
	is      => read_only,
	isa     => InstanceOf[Template],
	lazy    => 1,
	default => sub {
		return Template->new(
			TYPE   => 'FILEHANDLE',
			SOURCE => \*DATA,
		);
	},
);

has storage => (
	is      => read_only,
	isa     => InstanceOf[Dir],
	default => sub { Dir->new('/tmp/perl-web-paste-simple/') },
);

has codemirror => (
	is      => read_only,
	isa     => Str,
	default => sub { 'http://buzzword.org.uk/2012/codemirror-2.36' },
);

has app => (
	is      => read_only,
	isa     => CodeRef,
	lazy    => 1,
	builder => '_build_app',
);

has modes => (
	is      => read_only,
	isa     => ArrayRef[Str],
	default => sub {
		[qw(
			htmlmixed xml css javascript
			clike perl php ruby python lua haskell
			diff sparql ntriples plsql
		)]
	},
);

has default_mode => (
	is      => read_only,
	isa     => Str,
	default => sub { 'perl' },
);

sub _build_app
{
	my $self = shift;

	$self->storage->mkpath unless -d $self->storage;
	confess "@{[$self->storage]} is not writeable" unless -w $self->storage;

	return sub {
		my $req = Request->new(shift);
		$self->dispatch($req)->finalize;
	};
}

sub dispatch
{
	my ($self, $req) = @_;

	if ($req->method eq 'POST') {
		return $self->create_paste($req);
	}
	elsif ($req->path =~ m{^/([^.]+)}) {
		return $self->retrieve_paste($req, $1);
	}
	elsif ($req->path eq '/') {
		return $self->show_template($req, {});
	}
	else {
		return $self->show_error("Bad URI", 404);
	}
}

sub make_paste_id
{
	my $id = shift->uuid_gen->create_b64;
	$id =~ tr{+/}{-_};
	$id =~ s{=+$}{};
	return $id;
}

sub create_paste
{
	my ($self, $req) = @_;
	my $id = $self->make_paste_id;
	$self->storage->file("$id.paste")->spew(
		to_json( +{ %{$req->parameters} } ),
	);
	return Response->new(
		302,
		[
			'Content-Type' => 'text/plain',
			'Location'     => $req->base . "/$id",
		],
		"Yay!",
	);
}

sub retrieve_paste
{
	my ($self, $req, $id) = @_;
	my $file = $self->storage->file("$id.paste");
	-r $file or return $self->show_error("Bad file", 404);
	my $data = from_json($file->slurp);

	exists $req->parameters->{raw}
		? Response->new(200, ['Content-Type' => 'text/plain'], $data->{paste})
		: $self->show_template($req, $data);
}

sub show_template
{
	my ($self, $req, $data) = @_;
	my $page = $self->template->fill_in(
		HASH => {
			DATA       => encode_entities_numeric($data->{paste} // ''),
			MODE       => encode_entities_numeric($data->{mode}  // $self->default_mode),
			MODES      => $self->modes,
			PACKAGE    => ref($self),
			VERSION    => $self->VERSION,
			CODEMIRROR => $self->codemirror,
			APP        => $self,
			REQUEST    => $req,
		},
	);
	Response->new(200, ['Content-Type' => 'text/html'], $page);
}

sub show_error
{
	my ($self, $err, $code) = @_;
	Response->new(($code//500), ['Content-Type' => 'text/plain'], "$err\n");
}


1;

=head1 NAME

Web::Paste::Simple - simple PSGI-based pastebin-like website

=head1 SYNOPSIS

	#!/usr/bin/plackup
	use Web::Paste::Simple;
	Web::Paste::Simple->new(
		storage    => Path::Class::Dir->new(...),
		codemirror => "...",
		template   => Text::Template->new(...),
	)->app;

=head1 DESCRIPTION

Web::Paste::Simple is a lightweight PSGI app for operating a
pastebin-like website. It provides syntax highlighting via the
L Javascript library. It
should be fast enough for deployment via CGI.

It does not provide any authentication facilities or similar,
instead relying on you to use subclassing/roles or L
middleware to accomplish such things.

=head2 Constructor

=over

=item C<< new(%attrs) >>

Standard Moose-style constructor.

This class is not based on Moose though; instead it uses L.

=back

=head2 Attributes

The following attributes are defined:

=over

=item C

A L indicating the directory where pastes
should be stored. Pastes are kept indefinitely. Each is a single
file.

=item C

Path to the CodeMirror syntax highlighter as a string. For example,
if CodeMirror is available at C<< http://example.com/js/lib/codemirror.js >>
then this string should be C<< http://example.com/js >> with no trailing
slash.

This defaults to an address on my server, but for production sites,
I set up your own copy: it only takes a couple of minutes;
just a matter of unzipping a single archive. I offer no guarantees
about the continued availability of my copy of CodeMirror.

Nothing is actually done with this variable, but it's passed to the
template.

=item C