#!perl
use strict;
use warnings;
use Test::More;
use Plack::Test;
use JSON;
use IO::Zlib;
use Path::Class;
use HTTP::Date;
use HTTP::Request::Common;
use Pinto::Server;
use Pinto::Constants qw(:server :protocol);
use lib 't/lib';
use Pinto::Tester;
use Pinto::Tester::Util qw(make_dist_archive);
#------------------------------------------------------------------------------
# Setup...
my $t       = Pinto::Tester->new;
my %opts    = ( root => $t->pinto->root );
my $app     = Pinto::Server->new(%opts)->to_app;
my @headers = (Accept => $PINTO_PROTOCOL_ACCEPT);
#------------------------------------------------------------------------------
# Fetching an index...
test_psgi
    app    => $app,
    client => sub {
    my $cb  = shift;
    my $req = GET('modules/02packages.details.txt.gz');
    my $res = $cb->($req);
    is $res->code, 200, 'Correct status code';
    is $res->header('Content-Type'), 'application/x-gzip', 'Correct Type header';
    cmp_ok $res->header('Content-Length'), '>', 4000, 'Reasonable Length header';  # Actual length may vary
    cmp_ok $res->header('Content-Length'), '<', 7000, 'Reasonable Length header';  # Actual length may vary
    is $res->header('Content-Length'), length $res->content, 'Length header matches actual length';
    is $res->header('Cache-Control'), 'no-cache', 'Got a "Cache-Control: no-cache" header';
    isnt str2time( $res->header('Last-Modified') ), undef, 'Last-Modified header contains a proper HTTP::Date string';
    };
#------------------------------------------------------------------------------
# Test fetching legacy indexes (used by the cpan[1] client)
test_psgi
    app    => $app,
    client => sub {
    my $cb = shift;
    my @paths = qw(authors/01mailrc.txt.gz modules/03modlist.data.gz);
    for my $path (@paths) {
        for my $prefix ( 'stacks/master/', '' ) {
            my $url = $prefix . $path;
            my $req = GET($url);
            my $res = $cb->($req);
            is $res->code, 200, "Got response for $url";
            is $res->header('Cache-Control'), "no-cache", "$url got a 'Cache-Control: no-cache' header";
        }
    }
    };
#------------------------------------------------------------------------------
# Add an archive, then fetch it back.  Finally, check that all packages in the
# archive are present in the listing
subtest 'validate archive' => sub {
    my $archive = make_dist_archive('TestDist-1.0=Foo~0.7; Bar~0.8')->stringify;
    test_psgi
        app    => $app,
        client => sub {
        my $cb     = shift;
        my $params = { author => 'THEBARD', recurse => 0, message => 'test', archives => [$archive] };
        my $req    = POST( 'action/add', @headers, Content => { action => encode_json($params) } );
        my $res    = $cb->($req);
        action_response_ok($res);
        };
    test_psgi
        app    => $app,
        client => sub {
        my $cb     = shift;
        my $params = { stack => 'master' };
        my $req    = POST( 'action/lock', @headers, Content => { action => encode_json($params) } );
        my $res    = $cb->($req);
        action_response_ok($res);
        };
    test_psgi
        app    => $app,
        client => sub {
        my $cb     = shift;
        my $params = { author => 'THEBARD', recurse => 0, message => 'test', archives => [$archive] };
        my $req    = POST( 'action/add', @headers, Content => { action => encode_json($params) } );
        my $res    = $cb->($req);
        action_response_not_ok( $res, qr{is locked} );
        };
    test_psgi
        app    => $app,
        client => sub {
        my $cb  = shift;
        my $url = 'stacks/master/authors/id/T/TH/THEBARD/TestDist-1.0.tar.gz';
        my $req = GET($url);
        my $res = $cb->($req);
        is $res->code, 200, "Correct status code for GET $url";
        is $res->header('Content-Type'), 'application/x-gzip', "Correct Type header for GET $url";
        is $res->header('Content-Length'), -s $archive, "Length header matches actual archive size for GET $url";
        is $res->header('Content-Length'), length $res->content,
            "Length header matches actual content length for GET $url";
        };
    my $last_modified;
    test_psgi
        app    => $app,
        client => sub {
        my $cb  = shift;
        my $url = 'stacks/master/authors/id/T/TH/THEBARD/TestDist-1.0.tar.gz';
        my $req = HEAD($url);
        my $res = $cb->($req);
        $last_modified = $res->header('Last-Modified');
        isnt str2time($last_modified), undef, "Last-Modified header contains a proper HTTP::Date string for HEAD $url";
        is $res->code, 200, "Correct status code for HEAD $url";
        is $res->header('Content-Type'), 'application/x-gzip', "Correct Type header for HEAD $url";
        is $res->header('Content-Length'), -s $archive, "Length header matches actual archive size for HEAD $url";
        is length $res->content, 0, "No content returned for HEAD $url";
        };
    test_psgi
        app    => $app,
        client => sub {
        my $cb  = shift;
        my $url = 'stacks/master/authors/id/T/TH/THEBARD/TestDist-1.0.tar.gz';
        my $req = GET( $url, 'If-Modified-Since' => $last_modified );
        my $res = $cb->($req);
        is $res->code, 304, "Correct status code for unmodified $url";
        is $res->header('Content-Type'), undef, "No Content-Type header for 304 response";
        is $res->header('Content-Length'), undef, "No Content-Length header for 304 response";
        is length $res->content, 0, "No content returned for 304 response";
        };
    test_psgi
        app    => $app,
        client => sub {
        my $cb     = shift;
        my $params = {};
        my $req    = POST( 'action/list', @headers, Content => { action_args => encode_json($params) } );
        my $res    = $cb->($req);
        is $res->code, 200, 'Correct status code';
        # Note that the lines of the listing itself should NOT contain
        # the $PINTO_PROTOCOL_DIAG_PREFIX in front of each line.
        like $res->content, qr{\s Foo \s+ 0.7 \s+ \S+ \n}mx, 'Listing contains the Foo package';
        like $res->content, qr{\s Bar \s+ 0.8 \s+ \S+ \n}mx, 'Listing contains the Bar package';
        };
};
#------------------------------------------------------------------------------
# Make two stacks, add a different version of a dist to each stack, then fetch
# the index for each stack.  The indexes should contain different dists.
for my $v ( 1, 2 ) {
    my $stack   = "stack_$v";
    my $archive = make_dist_archive("Fruit-$v=Apple~$v; Orange~$v")->stringify;
    test_psgi
        app    => $app,
        client => sub {
        my $cb     = shift;
        my $params = { stack => $stack };
        my $req    = POST( 'action/new', @headers, Content => { action => encode_json($params) } );
        my $res    = $cb->($req);
        action_response_ok($res);
        };
    test_psgi
        app    => $app,
        client => sub {
        my $cb     = shift;
        my $params = { author => 'JOHN', recurse => 0, stack => $stack, message => 'test', archives => [$archive] };
        my $req    = POST( 'action/add', @headers, Content => { action => encode_json($params) } );
        my $res    = $cb->($req);
        action_response_ok($res);
        };
    test_psgi
        app    => $app,
        client => sub {
        my $cb  = shift;
        my $req = GET("stacks/$stack/modules/02packages.details.txt.gz");
        my $res = $cb->($req);
        is $res->code, 200, 'Correct status code';
        # Write the index to a file
        my $temp = File::Temp->new;
        print {$temp} $res->content;
        close $temp;
        # Slurp index contents into memory
        my $fh = IO::Zlib->new( $temp->filename, "rb" ) or die $!;
        my $index = join '', <$fh>;
        close $fh;
        # Test index contents
        for (qw(Apple Orange)) {
            like $index, qr{^ $_ \s+ $v  \s+ J/JO/JOHN/Fruit-$v.tar.gz $}mx, "index contains package $_-$v";
        }
        };
}
#------------------------------------------------------------------------------
# GET invalid path...
test_psgi
    app    => $app,
    client => sub {
    my $cb  = shift;
    my $req = GET('bogus/path');
    my $res = $cb->($req);
    is $res->code, 404, 'Correct status code';
    is $res->header('Content-Type'),   'text/plain';
    is $res->header('Content-Length'), length $res->content;
    like $res->content, qr{not found}i, 'File not found message';
    };
#------------------------------------------------------------------------------
# POST invalid action
test_psgi
    app    => $app,
    client => sub {
    my $cb     = shift;
    my $params = {};
    my $req    = POST( 'action/bogus', @headers, Content => { action => encode_json($params) } );
    my $res    = $cb->($req);
    action_response_not_ok( $res, qr{Can't locate Pinto/Action/Bogus.pm}i );
    };
#------------------------------------------------------------------------------
# Unversioned client (no Accept header)
test_psgi
    app    => $app,
    client => sub {
    my $cb = shift;
    my $req = POST( 'action/nop', Content => { action => encode_json({}) } );
    my $res = $cb->($req);
    is $res->code, 415, 'Unsupported media type status';
    like $res->content, qr/too old/;
    like $res->content, qr/upgrade pinto/;
    };
#------------------------------------------------------------------------------
# Client version is too old (i.e. server is too new)
test_psgi
    app    => $app,
    client => sub {
    my $cb = shift;
    my @headers = (Accept => 'application/vnd.pinto.v0+text');
    my $req     = POST( 'action/nop', Content => { action => encode_json({}) } );
    my $res     = $cb->($req);
    is $res->code, 415, 'Unsupported media type status';
    like $res->content, qr/too old/;
    like $res->content, qr/upgrade pinto/;
    };
#------------------------------------------------------------------------------
# # Client version is too new (i.e. server is too old)
test_psgi
    app    => $app,
    client => sub {
    my $cb = shift;
    my @headers = (Accept => 'application/vnd.pinto.v99+text');
    my $req     = POST( 'action/nop', @headers, Content => { action => encode_json({}) } );
    my $res     = $cb->($req);
    is $res->code, 415, 'Unsupported media type status';
    like $res->content, qr/too new/;
    like $res->content, qr/upgrade pintod/;
    };
#------------------------------------------------------------------------------
sub action_response_ok {
    my ( $response, $pattern, $test_name ) = @_;
    $test_name ||= sprintf '%s %s', $response->request->method, $response->request->uri;
    # Report failues from caller's perspective
    local $Test::Builder::Level = $Test::Builder::Level + 3;
    my $type = $response->header('Content-Type');
    is $type, 'text/plain', "Content-Type response header from $test_name";
    my $status = $response->code;
    is $status, 200, "Succesful status code for $test_name";
    my $content = $response->content;
    like $content, qr{$PINTO_PROTOCOL_STATUS_OK\n$}, "Response ends with status-ok for $test_name";
    like $content, $pattern, "Response content matches for $test_name"
        if $pattern;
}
#------------------------------------------------------------------------------
sub action_response_not_ok {
    my ( $response, $pattern, $test_name ) = @_;
    $test_name ||= sprintf '%s %s', $response->request->method, $response->request->uri;
    # Report failues from caller's perspective
    local $Test::Builder::Level = $Test::Builder::Level + 3;
    my $type = $response->header('Content-Type');
    is $type, 'text/plain', "Content-Type response header from $test_name";
    my $status = $response->code;
    is $status, 200, "Succesful status code for $test_name";
    my $content = $response->content;
    unlike $content, qr{$PINTO_PROTOCOL_STATUS_OK\n$}, "Response does not end with status-ok for $test_name";
    like $content, $pattern, "Response content matches for $test_name"
        if $pattern;
}
#------------------------------------------------------------------------------
done_testing;