[untitled]

# Copyright (C) 2008  Martyn Smith
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

package PasteBot;

use strict;
use warnings;
no warnings qw(redefine);

use Digest::MD5 qw();
use File::Type;
use File::Slurp;
use Text::VimColor;
use FindBin;
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::Reload;
use Apache2::Const -compile => qw(OK FORBIDDEN NOT_FOUND);
use APR::Request::Apache2;
use APR::Table;

my $storage_path = $ENV{PASTEBOT_STORAGE_DIR};
unless ( defined $storage_path ) {
    $storage_path = '/tmp/paste';
    mkdir $storage_path unless -d $storage_path;
}

my $filetype_for = {
    'text/html' => 'html',
};

sub get_params {
    my $apr = shift;
    my $params = {};

    foreach my $key ( $apr->param ) {
        my @values = $apr->param($key);
        $params->{$key} = @values == 1 ? $values[0] : \@values;
    }

    return $params;
};

sub handler {
    # get Apache2::RequestRec object
    my $r = shift;
    my $apr = APR::Request::Apache2->handle($r);

    # get/post parameters
    my $get = scalar($apr->args);
    my $post = scalar($apr->body);
    my $args = scalar($apr->param);

    # content posted to be pastebotted
    if ( $r->method eq 'POST' and exists $post->{text} ) {
        my $digest = substr Digest::MD5::md5_hex($post->{text}), 26;
        write_file($storage_path . '/' . $digest, $post->{text});
        if (defined $post->{filetype} and $post->{filetype} =~ /\S/) {
            write_file($storage_path . '/' . $digest . '.filetype', $post->{filetype});
        }

        $r->headers_out->add('Location' => 'http://' . $r->hostname . '/' . $digest);
        $r->status(303);
    }
    # request for the homepage
    elsif ( $r->uri eq '/' ) {
        $r->content_type('text/html');
        home_page($r);
    }
    # request for existing pastebot content
    elsif ( $r->uri =~ m{^/([a-z0-9]{6})(.txt)?$} and -f $storage_path . '/' . $1 ) {
        my $contents = read_file($storage_path . '/' . $1);

        if ( $2 ) {
            $r->content_type('text/plain');
            print $contents;
        }
        else {
            my $mimetype = File::Type->new->checktype_contents($contents);
            my $filetype = $get->{filetype};

            $filetype ||= read_file($storage_path . '/' . $1 . '.filetype') if -f $storage_path . '/' . $1 . '.filetype';
            $filetype ||= $filetype_for->{$mimetype};

            my $syntax = Text::VimColor->new(
                string => $contents,
                html_full_page => 1,
                filetype => $filetype,
            );

            $r->content_type('text/html');
            print $syntax->html;
        }
    }
    # request for source listing
    elsif ( $r->uri eq '/source' or $r->uri eq '/source.txt' ) {
        my $contents = read_file($INC{__PACKAGE__ . '.pm'});

        if ( $r->uri eq '/source' ) {
            my $syntax = Text::VimColor->new(
                string => $contents,
                html_full_page => 1,
                filetype => 'perl',
            );

            $r->content_type('text/html');
            print $syntax->html;
        }
        else {
            $r->content_type('text/plain');
            print $contents;
        }
    }
    # don't know what it is, 404
    else {
        $r->status(404);
        return Apache2::Const::NOT_FOUND;
    }

    return Apache2::Const::OK;
}

# Function to render the homepage
sub home_page {
    my $r = shift;

    print(q|<html>
    <head>
        <style type="text/css">
            textarea {
                width: 100%;
                height: 50%;
            }
        </style>
        <title>paste.dollyfish.net.nz</title>
    </head>
    <body onload="document.f.text.focus()">
        <form method="post" name="f">
            <input type="submit" value="Paste">
            <textarea name="text"></textarea>
            <input type="submit" value="Paste">
|);
    if ( -f '/usr/share/vim/vimcurrent/synmenu.vim' ) {
        print q{<select name="filetype">};
        print q{<option value="">Automatic Detection</option>};
        foreach my $line ( read_file('/usr/share/vim/vimcurrent/synmenu.vim') ) {
            next unless ( my ( $syntax, $filetype ) = $line =~ /Syntax.[\w-]+\.(.*) :cal SetSyn\("(.*?)"/ );
            $syntax =~ s/\\ / /g;
            print '<option value="' . $filetype . '">' . $syntax . '</option>';
        }
        print q{</select>};
    }
    print(q|
        </form>
        <hr>
        <p>
            Checkout the <a href="http://dollyfish.net.nz/projects/pastebot">PasteBot homepage</a>
            , or <a href="source">source code</a> powering this instance.
        </p>
        <script type="text/javascript">
            var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");
            document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));
        </script>
        <script type="text/javascript">
            var pageTracker = _gat._getTracker("UA-1416732-4");
            pageTracker._initData();
            pageTracker._trackPageview();
        </script>
    </body>
</html>
|);

}

1;

__END__

=head1 Apache Configuration

<VirtualHost *:80>
    ServerName paste.dollyfish.net.nz

    <Perl>
        use lib '/path/to/libdir';
    </Perl>

    PerlSetEnv PASTEBOT_STORAGE_DIR /path/to/storage

    <Location />
        SetHandler perl-script
        PerlHandler PasteBot
    </Location>
</VirtualHost>

=cut