File Coverage

blib/lib/Lavoco/Website.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package Lavoco::Website;

use 5.006;

use Moose;

use Data::Dumper;
use DateTime;
use Email::Stuffer;
use Encode;
use File::Slurp;
use FindBin qw($Bin);
use JSON;
use Log::AutoDump;
use Plack::Handler::FCGI;
use Plack::Request;
use Template;
use Term::ANSIColor;
use Time::HiRes qw(gettimeofday);

$Data::Dumper::Sortkeys = 1;

=head1 NAME

Lavoco::Website - EXPERIMENTAL FRAMEWORK.

Framework to run small websites, URL dispatching based on a flexible config file, to render Template::Toolkit templates.

=head1 VERSION

Version 0.12

=cut

our $VERSION = '0.12';

$VERSION = eval $VERSION;

=head1 SYNOPSIS

A FastCGI web-app for serving Template::Toolkit templates.

This is an experimental framework to control various small websites, use at your own risk.

 use Lavoco::Website;

 my $website = Lavoco::Website->new( name => 'Example' );

 my $action = lc( $ARGV[0] );   # (start|stop|restart)

 $website->$action;

=cut

=head1 METHODS

=head2 Class Methods

=head3 new

Creates a new instance of the website object.

=head2 Instance Methods

=cut

has  name      => ( is => 'rw', isa => 'Str',  default => 'Website' );
has  processes => ( is => 'rw', isa => 'Int',  default => 5         );
has  base      => ( is => 'rw', isa => 'Str',  lazy => 1, builder => '_build_base'      );
has  dev       => ( is => 'rw', isa => 'Bool', lazy => 1, builder => '_build_dev'       );
has _pid       => ( is => 'rw', isa => 'Str',  lazy => 1, builder => '_build__pid'      );
has _socket    => ( is => 'rw', isa => 'Str',  lazy => 1, builder => '_build__socket'   );
has  templates => ( is => 'rw', isa => 'Str',  lazy => 1, builder => '_build_templates' );

sub _build_base
{
    return $Bin;
}

sub _build_dev
{
    my $self = shift;

    return 0 if $self->base =~ m:/live:;

    return 1;
}

sub _build__pid
{
    my $self = shift;

    return $self->base . '/website.pid';
}

sub _build__socket
{
    my $self = shift;

    return $self->base . '/website.sock';
}

sub _build_templates
{
    my $self = shift;

    return $self->base . '/templates';
}

=head3 name

The identifier for the website, used as the process title.

=head3 base

The base directory of the application, using L<FindBin>.

=head3 dev

A simple boolean flag to indicate whether you're running a development instance of the website.

It's on by default, and currently turned off if the base directory contains C</live>.  Feel free to set it based on your own logic before calling C<start()>.

I typically use working directories such as C</home/user/www.example.com/dev> and C</home/user/www.example.com/live>.

This flag is useful to disable things like Google Analytics on the dev site.

The website object is avilable to all templates under the name C<website>.

e.g. C<[% IF website.dev %]...>

=head3 processes

Number of FastCGI process to spawn, 5 by default.

 $website->processes( 10 );

=head3 templates

The directory containing the TT templates, by default it's C<$website-E<gt>base . '/templates'>.

=head3 start

Starts the FastCGI daemon.  Performs basic checks of your environment and dies if there's a problem.

=cut

sub start
{
    my $self = shift;

    if ( -e $self->_pid )
    {
        print "PID file " . $self->_pid . " already exists, I think you should kill that first, or specify a new pid file with the -p option\n";

        return $self;
    }

    $self->_init;

    print "Building FastCGI engine...\n";

    my $server = Plack::Handler::FCGI->new(
        nproc      =>   $self->processes,
        listen     => [ $self->_socket ],
        pid        =>   $self->_pid,
        detach     =>   1,
        proc_title =>   $self->name,
    );

    $server->run( $self->_handler );
}

sub _init
{
    my ( $self, %args ) = @_;

    ###############################
    # make sure there's a log dir #
    ###############################

    printf( "%-50s", "Checking logs directory");

    my $log_dir = $self->base . '/logs';

    if ( ! -e $log_dir || ! -d $log_dir )
    {
        _print_red( "[ FAIL ]\n" );
        print $log_dir . " does not exist, or it's not a folder.\nExiting...\n";
        exit;
    }

    _print_green( "[  OK  ]\n" );

    #####################################
    # make sure there's a templates dir #
    #####################################

    printf( "%-50s", "Checking templates directory");

    if ( ! -e $self->templates || ! -d $self->templates )
    {
        _print_red( "[ FAIL ]\n" );
        print $self->templates . " does not exist, or it's not a folder.\nExiting...\n";
        exit;
    }

    _print_green( "[  OK  ]\n" );

    ###########################
    # make sure 404.tt exists #
    ###########################

    printf( "%-50s", "Checking 404 template");

    my $template_404_file = $self->templates . '/404.tt';

    if ( ! -e $template_404_file )
    {
        _print_red( "[ FAIL ]\n" );
        print $template_404_file . " does not exist.\nExiting...\n";
        exit;
    }

    _print_green( "[  OK  ]\n" );

    ########################
    # load the config file #
    ########################

    printf( "%-50s", "Checking config");

    my $config_file = $self->base . '/website.json';

    if ( ! -e $config_file )
    {
        _print_red( "[ FAIL ]\n" );
        print $config_file . " does not exist.\nExiting...\n";
        exit;
    }

    my $string = read_file( $config_file, { binmode => ':utf8' } );

    my $config = undef;

    eval {
        $config = decode_json $string;
    };

    if ( $@ )
    {
        _print_red( "[ FAIL ]\n" );
        print "Config file error...\n" . $@ . "Exiting...\n";
        exit;
    }

    ###################################
    # basic checks on the config file #
    ###################################

    if ( ! $config->{ pages } )
    {
        _print_red( "[ FAIL ]\n" );
        print "'pages' attribute missing at top level.\nExiting...\n";
        exit;
    }

    if ( ref $config->{ pages } ne 'ARRAY' )
    {
        _print_red( "[ FAIL ]\n" );
        print "'pages' attribute is not a list.\nExiting...\n";
        exit;
    }

    if ( scalar @{ $config->{ pages } } == 0 )
    {
        _print_organge( "[ISSUE]\n" );
        print "No 'pages' defined in config, this will result in a 404 for all requests.\n";
    }

    my %paths = ();

    foreach my $each_page ( @{ $config->{ pages } } )
    {
        if ( ! $each_page->{ path } )
        {
            _print_red( "[ FAIL ]\n" );
            print "'path' attribute missing for page..." . ( Dumper $each_page );
            exit;
        }

        if ( ! $each_page->{ template } )
        {
            _print_red( "[ FAIL ]\n" );
            print "'template' attribute missing for page..." . ( Dumper $each_page );
            exit;
        }

        if ( exists $paths{ $each_page->{ path } } )
        {
            _print_red( "[ FAIL ]\n" );
            print "Path '" . $each_page->{ path } . "' found more than once.\nExiting...\n";
            exit;
        }

        $paths{ $each_page->{ path } } = 1;
    }

    _print_green( "[  OK  ]\n" );

    return $self;
}

sub _print_green
{
    my $string = shift;
    print color 'bold green';
    print $string;
    print color 'reset';
}

sub _print_orange
{
    my $string = shift;
    print color 'bold orange';
    print $string;
    print color 'reset';
}

sub _print_red
{
    my $string = shift;
    print color 'bold red';
    print $string;
    print color 'reset';
}

=head3 stop

Stops the FastCGI daemon.

=cut

sub stop
{
    my $self = shift;

    if ( ! -e $self->_pid )
    {
        return $self;
    }

    open( my $fh, "<", $self->_pid ) or die "Cannot open pidfile: $!";

    my @pids = <$fh>;

    close $fh;

    chomp( $pids[0] );

    print "Killing pid $pids[0] ...\n";

    kill 15, $pids[0];

    return $self;
}

=head3 restart

Restarts the FastCGI daemon, with a 1 second delay between stopping and starting.

=cut

sub restart
{
    my $self = shift;

    $self->stop;

    sleep 1;

    $self->start;

    return $self;
}

=head1 CONFIG

Currently only JSON is supported, the config file should be named C<website.json> and should be placed in the base directory of your website.

See the C<examples> directory for a sample JSON config file.

 {
    "pages" : [
       {
          "path" : "/",
          "template":"index.tt",
          ...
       },
       ...
    ]
    ...
    "send_alerts_from":"The Example Website <[e-mail]>",
    "send_404_alerts_to":"[e-mail]",
    ...
 }

The entire config hash is available in all templates via [% config %], and is flexible, there are only a couple of mandatory/reserved attributes.

The mandatory field in the config is C<pages>, which is an array of JSON objects.

Each C<page> object should have a C<path> (to match a URL) and C<template>.

All other fields are up to you, to fit your requirements.

When a request is made, a lookup is performed for a page by matching the C<path> - the associated C<template> will be rendered.

If no page is found, the template C<404.tt> will be rendered, make sure you have this file ready in the templates directory.

The C<page> object is available in the templates.

It is often useful to have sub-pages, simply create a C<pages> attribute in a C<page> object.

If a sub-page is selected, an extra key for C<parents> is included in the C<page> object as a list of the parent pages, this is useful for building breadcrumb links.

=cut

# returns a code-ref for the FCGI handler/server.

sub _handler
{
    my $self = shift;

    return sub {

        ##############
        # initialise #
        ##############

        my $req = Plack::Request->new( shift );

        my %stash = (
            website  => $self,
            req      => $req,
            now      => DateTime->now,
            started  => join( '.', gettimeofday ),
        );

        my $log = Log::AutoDump->new( base_dir => $stash{ website }->base . '/logs', filename => 'website.log' );

        $log->debug("Started");

        my $path = $req->uri->path;

        $log->debug( "Requested path: " . $path );

        ##################
        # get the config #
        ##################

        $stash{ config } = $stash{ website }->_get_config( log => $log );

        ###############
        # sitemap xml #
        ###############

        if ( $path eq '/sitemap.xml' )
        {
            return $stash{ website }->_sitemap( log => $log, req => $req, stash => \%stash );
        }

        ##########################################################################
        # find a matching 'page' from the config that matches the requested path #
        ##########################################################################

        foreach my $each_page ( @{ $stash{ config }->{ pages } } )
        {
            if ( $path eq $each_page->{ path } )
            {
                $stash{ page } = $each_page;

                last;
            }

            if ( ref $each_page->{ pages } eq 'ARRAY' )
            {
                foreach my $each_sub_page ( @{ $each_page->{ pages } } )
                {
                    if ( $path eq $each_sub_page->{ path } )
                    {
                        $stash{ page } = $each_sub_page;

                        $stash{ page }->{ parents } = [];

                        push @{ $stash{ page }->{ parents } }, $each_page;

                        last;
                    }
                }
            }
        }

        $log->debug( "Matching page found in config" ) if exists $stash{ page };

        #######
        # 404 #
        #######

        if ( ! exists $stash{ page } )
        {
            return $stash{ website }->_404( log => $log, req => $req, stash => \%stash );
        }

        my $res = $req->new_response;

        $res->status( 200 );

        my $tt = Template->new( ENCODING => 'UTF-8', INCLUDE_PATH => $stash{ website }->templates );

        $log->debug("Processing template: " . $stash{ website }->templates . "/" . $stash{ page }->{ template } );

        my $body = '';

        $tt->process( $stash{ page }->{ template }, \%stash, \$body ) or $log->debug( $tt->error );

        $res->content_type('text/html; charset=utf-8');

        $res->body( encode( "UTF-8", $body ) );

        $stash{ took } = join( '.', gettimeofday ) - $stash{ started };

        $log->debug( "The stash contains...", \%stash );

        $log->debug( "Took " . sprintf("%.5f", $stash{ took } ) . " seconds");

        #######################################
        # cleanup (circular references, etc.) #
        #######################################

        delete $stash{ page }->{ parents } if exists $stash{ page };

        return $res->finalize;
    }
}

sub _sitemap
{
    my ( $self, %args ) = @_;

    my $log = $args{ log };
    my $req = $args{ req };
    my $stash = $args{ stash };

    my $base = ($req->env->{'psgi.url_scheme'} || "http") .
        "://" . ($req->env->{HTTP_HOST} || (($req->env->{SERVER_NAME} || "") . ":" . ($req->env->{SERVER_PORT} || 80)));

    my $sitemap = '<?xml version="1.0" encoding="UTF-8"?>';

    $sitemap .= "\n";

    $sitemap .= '<urlset xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="http://www.sitemaps.org/schemas/sitemap/0.9 http://www.sitemaps.org/schemas/sitemap/0.9/sitemap.xsd">';

    $sitemap .= "\n";

    foreach my $each_page ( @{ $stash->{ config }->{ pages } } )
    {
        $sitemap .= "<url><loc>" . $base . $each_page->{ path } . "</loc></url>\n";

        if ( ref $each_page->{ pages } eq 'ARRAY' )
        {
            foreach my $each_sub_page ( @{ $each_page->{ pages } } )
            {
                $sitemap .= "<url><loc>" . $base . $each_sub_page->{ path } . "</loc></url>\n";
            }
        }
    }

    $sitemap .= "</urlset>\n";

    my $res = $req->new_response;

    $res->status(200);

    $res->content_type('application/xml; charset=utf-8');

    $res->body( encode( "UTF-8", $sitemap ) );

    return $res->finalize;
}

sub _404
{
    my ( $self, %args ) = @_;

    my $log = $args{ log };
    my $req = $args{ req };
    my $stash = $args{ stash };

    $stash->{ page } = { template => '404.tt' };

    if ( $stash->{ config }->{ send_alerts_from } && $stash->{ config }->{ send_404_alerts_to } )
    {
        $stash->{ website }->_send_email(
            from      => $stash->{ config }->{ send_alerts_from },
            to        => $stash->{ config }->{ send_404_alerts_to },
            subject   => "404 - " . $req->uri,
            text_body => "404 - " . $req->uri . "\n\nReferrer: " . ( $req->referer || 'None' ) . "\n\n" . Dumper( $req ) . "\n\n" . Dumper( \%ENV ),
        );
    }

    my $res = $req->new_response;

    $res->status( 404 );

    $res->content_type('text/html; charset=utf-8');

    my $tt = Template->new( ENCODING => 'UTF-8', INCLUDE_PATH => $stash->{ website }->templates );

    $log->debug("Processing template: " . $stash->{ website }->templates . "/" . $stash->{ page }->{ template } );

    my $body = '';

    $tt->process( $stash->{ page }->{ template }, $stash, \$body ) or $log->debug( $tt->error );

    $res->content_type('text/html; charset=utf-8');

    $res->body( encode( "UTF-8", $body ) );

    return $res->finalize;
}

sub _get_config
{
    my ( $self, %args ) = @_;

    my $log = $args{ log };

    my $filename = $self->base . '/website.json';

    $log->debug( "Opening config file: " . $filename );

    my $string = read_file( $filename, { binmode => ':utf8' } );

    my $config = undef;

    eval {
        $config = decode_json $string;
    };

    $log->debug( $@ ) if $@;

    return $config;
}

sub _send_email
{
    my ( $self, %args ) = @_;

    if ( $args{ to } )
    {
        Email::Stuffer->from( $args{ from } )
            ->to( $args{ to } )
            ->subject( $args{ subject } )
            ->text_body( $args{ text_body } )
            ->send;
    }

    return $self;
}

=head1 TODO

More documentation.

=head1 AUTHOR

Rob Brown, C<< <rob at intelcompute.com> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-lavoco-website at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Lavoco-Website>.  I will be notified, and then you will
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Lavoco::Website


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Lavoco-Website>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Lavoco-Website>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Lavoco-Website>

=item * Search CPAN

L<http://search.cpan.org/dist/Lavoco-Website/>

=back

=head1 LICENSE AND COPYRIGHT

Copyright 2014 Rob Brown.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1;