File Coverage

blib/lib/Wallflower.pm

Criterion	Covered	Total	%
statement	96	96	100.0
branch	44	44	100.0
condition	13	14	92.8
subroutine	17	17	100.0
pod	3	3	100.0
total	173	174	99.4

package Wallflower;
$Wallflower::VERSION = '1.013';
use strict;
use warnings;

use Plack::Util ();
use Path::Tiny ();
use URI;
use HTTP::Date qw( time2str str2time);
use HTTP::Headers::Fast;    # same as Plack::Response
use Carp;

# quick getters
for my $attr (qw( application destination env index url )) {
    no strict 'refs';
    *$attr = sub { $_[0]{$attr} };
}

# create a new instance
sub new {
    my ( $class, %args ) = @_;
    my $self = bless {
        destination => Path::Tiny->new('.'),
        env         => {},
        index       => 'index.html',
        url         => 'http://localhost/',
        %args,
    }, $class;

    # some basic parameter checking
    croak "application is required" if !defined $self->application;
    croak "destination is invalid"
        if !-e $self->destination || !-d $self->destination;

    # turn the url attribute into a URI object
    $self->{url} = URI->new( $self->url );

    # if the application is mounted somewhere
    my $path;
    if ( $path = $self->url->path and $path ne '/' ) {
        require Plack::App::URLMap;
        my $urlmap = Plack::App::URLMap->new;
        $urlmap->mount( $path => $self->application );
        $self->{application} = $urlmap->to_app;
    }

    return $self;
}

# url -> file converter
sub target {
    my ( $self, $uri ) = @_;

    # the URI must have a path
    croak "$uri has an empty path" if !length $uri->path;

    # URI ending with / have the empty string as their last path_segment
    my @segments = $uri->path_segments;
    $segments[-1] = $self->index if $segments[-1] eq '';

    # generate target file name
    return Path::Tiny->new( $self->destination, grep length, @segments );
}

# Wallflower::NULL drops the streamed data
for (qw( write close )) {
    no strict 'refs';
    *{"Wallflower::NULL::$_"} = sub { };
}

sub _build_handle {
    my ($file) = @_;

    # get a file to save the content in
    my $dir = $file->parent;
    eval { $dir->mkpath; 1; } or die "$@\n"
      if !-e $dir;
    open my $fh, '> :raw', $file    # no stinky crlf on Win32
      or die "Can't open $file for writing: $!\n";

    return $fh;
}

# save the URL to a file
sub get {
    my ( $self, $uri ) = @_;
    $uri = URI->new($uri) if !ref $uri;

    # absolute paths have the empty string as their first path_segment
    croak "$uri is not an absolute URI"
        if $uri->path && length +( $uri->path_segments )[0];

    # setup the environment
    my $env = {

        # current environment
        %ENV,

        # overridable defaults
        'psgi.errors' => \*STDERR,

        # current instance defaults
        %{ $self->env },
        ('psgi.url_scheme' => $self->url->scheme )x!! $self->url->scheme,

        # request-related environment variables
        REQUEST_METHOD => 'GET',

        # request attributes
        SCRIPT_NAME     => '',
        PATH_INFO       => $uri->path,
        REQUEST_URI     => $uri->path,
        QUERY_STRING    => '',
        SERVER_NAME     => $self->url->host,
        SERVER_PORT     => $self->url->port,
        SERVER_PROTOCOL => "HTTP/1.0",

        # wallflower defaults
        'psgi.streaming' => 1,
    };

    # add If-Modified-Since headers if the target file exists
    my $target = $self->target($uri);
    $env->{HTTP_IF_MODIFIED_SINCE} = time2str( ( stat _ )[9] ) if -e $target;

    # fixup URI (needed to resolve relative URLs in retrieved documents)
    $uri->scheme( $env->{'psgi.url_scheme'} ) if !$uri->scheme;
    $uri->host( $env->{SERVER_NAME} ) if !$uri->host;

    # get the content
    my ( $status, $headers, $file, $content ) = ( 500, [], '', '' );
    my $res = Plack::Util::run_app( $self->application, $env );

    if ( ref $res eq 'ARRAY' ) {
        ( $status, $headers, $content ) = @$res;
    }
    elsif ( ref $res eq 'CODE' ) {

        # https://metacpan.org/pod/PSGI#Delayed-Response-and-Streaming-Body
        $res->( sub {
            my $response = shift;

            # delayed response
            ( $status, $headers, $content ) = @$response;

            # streaming
            if ( !defined $content ) {
                return bless {}, 'Wallflower::NULL'
                  if $status ne '200';    # we don't care about the body
                return _build_handle( $file = $target );
            }
            return;
        } );
    }
    else { croak "Unknown response from application: $res"; }

    # save the content to a file
    if ( $status eq '200' ) {
        my $fh = defined $content && do {
            eval { _build_handle( $file = $target ) }
              or do { warn $@; return [ 999, [], '' ]; };
        };

        # copy content to the file
        if ( ref $content eq 'ARRAY' ) {
            print $fh @$content;
        }
        elsif ( ref $content eq 'GLOB' ) {
            local $/ = \8192;
            print {$fh} $_ while <$content>;
            close $content;
        }
        elsif ( eval { $content->can('getline') } ) {
            local $/ = \8192;
            while ( defined( my $line = $content->getline ) ) {
                print {$fh} $line;
            }
            $content->close;
        }
        elsif ( !defined $content ) { }    # already streamed
        else {
            croak "Don't know how to handle body: $content";
        }

        # finish
        close $fh;

        # if the app sent Last-Modified, set the local file date to that
        if ( my $last_modified = HTTP::Headers::Fast->new(@$headers)
             ->header('Last-Modified') ) {
            my $epoch = str2time( $last_modified );
            utime $epoch, $epoch, $file;
        }
    }

    return [ $status, $headers, $file ];
}

1;

__END__